Excel VBA - Поиск и копирование несоответствующих строк на другой рабочий лист

ProgramBox

Excel VBA — Поиск и копирование несоответствующих строк на другой рабочий лист

Post author:admin
Запись опубликована:12 января, 2022
Post category:Вопросы по программированию

#excel #vba

Вопрос:

Я хотел бы сравнить 2 столбца на одном листе, найти несоответствующие значения в столбце A по сравнению со столбцом D и скопировать все строки этих несоответствующих значений в столбце A на другой лист.

Вот образец рабочего листа:

Поэтому я хотел бы сравнить столбец A со столбцом D, найти значения, которые не совпадают, и скопировать все соответствующие строки из столбцов A и B на новый рабочий лист.

*Правка, я забыл включить свой код

 Dim CopyToRow As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim found As Range

'Start copying data to row 2 in Sheet2 (row counter variable)
CopyToRow = 2

Set rng1 = Range(ActiveSheet.Cells(2, 1), ActiveSheet.Cells(2, 1).End(xlDown))
Set rng2 = Range(ActiveSheet.Cells(4, 2), ActiveSheet.Cells(4, 2).End(xlDown))

For Each cell In rng1

Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)

If Not found Is Nothing Then

cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" amp; CopyToRow)

CopyToRow = CopyToRow   1

End If

Next cell

Большое спасибо и большая благодарность!

1. Предполагается, что это не бесплатная услуга по написанию кода, поэтому, пожалуйста, покажите, что вы пробовали, и объясните, где у вас возникли проблемы. Кроме того, укажите свою версию Excel и объясните, почему вам нужно это сделать с помощью VBA. Вы можете сделать это с помощью расширенного фильтра, объединить таблицы и сохранить только отдельные строки.

2. Мои извинения, я забыл добавить свой код, подробно описывающий проблему. Тем не менее, я ценю ваши отзывы!

3. Я думаю, что было бы проще всего использовать Power Query и выполнить LeftAnti тип соединения, используя оба столбца в качестве key . Это сохранит те строки в таблице 1, которых нет в таблице 2, и вы выведете результаты в новую книгу.

4. Спасибо вам за ваше обновление! Я не думал рассматривать запрос мощности для выполнения соединения типа LeftAnti. Где я могу найти дополнительные ресурсы, подробно описывающие это?

5. Вы можете выполнить поиск в Интернете с такими терминами, как Power Query и/или Power BI . Существует множество групп, блогов, учебных пособий и т. Д.

Ответ №1:

Я согласен с Роном Розенфельдом в том, что вам следовало продемонстрировать свою собственную попытку. Тем не менее, возможно, это окажет вам некоторую помощь. Не самый элегантный, но должен работать при условии, что вы обновите ссылки на свои собственные имена листов.

 Sub SOPractice()
    
    Dim SearchCell As Range 'each value being checked
    Dim SearchRng As Range 'column A
    Dim LastRow As Long
    Dim MatchFound As Range
    Dim i As Long: i = 1
    
    LastRow = YourSheet.Range("A" amp; Rows.Count).End(xlUp).Row
    
    With YourSheet
        Set SearchRng = .Range(.Cells(2, 1), .Cells(LastRow, 1))
    
    
    Application.ScreenUpdating = False
    
    For Each SearchCell In SearchRng
        Set MatchFound = .Range("D:D").Find _
        (What:=SearchCell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
        
        If MatchFound Is Nothing Then 'No match hence copy to other sheet
            .Range(SearchCell.Address, SearchCell.Offset(, 1)).Copy
            YourCopyToSheet.Cells(i, 1).PasteSpecial xlPasteAll
            i = i   1
        End If
    
    Next SearchCell
    
    End With

    Application.ScreenUpdating = True
    Application.CutCopyMode = False
        
End Sub

Ответ №2:

Я также нашел решение, используя объект словаря:

 Dim Cl As Range, Rng As Range, Dic As Object

Set Dic = CreateObject("scripting.dictionary")

With Dic
For Each Cl In MyWorksheet1Name.Range("D2", MyWorksheet1Name.Range("D" amp; Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
Next Cl
For Each Cl In MyWorksheet1Name.Range("A2", MyWorksheet1Name.Range("A" amp; Rows.Count).End(xlUp))
    If Not .Exists(Cl.Value) Then
    If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
    End If
Next Cl
End With

If Not Rng Is Nothing Then
    Rng.EntireRow.Copy MyWorksheet2Name.Range("A" amp; Rows.Count).End(xlUp)
End If

Ваше здоровье!

Метки: Excel VBA — Поиск и копирование несоответствующих строк на другой рабочий лист