Если 2 пары ячеек не равны, сделайте что-нибудь в VBA

Question

У меня есть 2 таблицы в Excel.Itemx, attributetex в attrDICTIONARY необходимо обновить на основе листа 2.

1. Я хочу просмотреть каждый элемент x, attributetex на листе 2
2. Если он не найден в attrDICTIONARY,добавьте новую строку с отсутствующим itemx, приписанным в

Примечание. Эти столбцы отсортированы в алфавитном порядке AZ по itemx.На листе 2 также имеется большое количество записей, относящихся к attrDICTIONARY.

attrDICTIONARY содержит:

column1 column2  
item1   attribute1  
item2   attribute2  
item4   attribute4

Лист 2 содержит:

column1 column2   
item1 attribute1   
item2 attribute2  
item3 attribute3  
item4 attribute4  

Я пробовал это:

 Sub addAttributesToAttrDICTIONARY()
'
' addAttributesToAttrDICTIONARY Macro
'

    Sheet2LastRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
    attrDictionaryLastRow = Worksheets("attrDICTIONARY").Range("C" & Rows.Count).End(xlUp).Row
    Dim i As Integer
    Dim j As Integer
    j = 1

    For i = 2 To Sheet2LastRow
        While j <= attrDictionaryLastRow
incrementj:
            j = j + 1
            If (StrComp(Worksheets("Sheet2").Cells(i, 1).Value, Worksheets("attrDICTIONARY").Cells(j, 2).Value)) = 0 And (StrComp(Worksheets("Sheet2").Cells(i, 2).Value, Worksheets("attrDICTIONARY").Cells(j, 3).Value)) = 0 Then
                GoTo Nexti
            Else
                Worksheets("attrDICTIONARY").Rows(j).Insert
                Worksheets("attrDICTIONARY").Cells(j, 2).Value = Worksheets("Sheet2").Cells(i, 1).Value
                Worksheets("attrDICTIONARY").Cells(j, 3).Value = Worksheets("Sheet2").Cells(i, 2).Value
                attrDictionaryLastRow = attrDictionaryLastRow + 1
                GoTo Nexti
            End If
        Wend
Nexti:
    Next i

End Sub

Поскольку таблицы отсортированы, я просто проверяю, совпадают ли они, если не добавить строку выше и добавить соответствующие значения.

Этот код работает до 4000 тысяч единиц.В этот момент кажется, что код перестает проверять дубликаты и просто добавляет новые строки для всего, толкая исходные значения вниз и создавая дубликаты.Я проверил, используя другой цветной шрифт для новых предметов.

Любая помощь будет оценена.Благодарю.

Answer 1

Попробуйте:

Sub addAttributesToAttrDICTIONARY()

    Dim wb As Workbook
    Dim wsAttr As Worksheet
    Dim wsData As Worksheet
    Dim rAttr As Range
    Dim aData As Variant
    Dim aAdd() As Variant
    Dim AddIndex As Long
    Dim i As Long, j As Long

    Set wb = ActiveWorkbook
    Set wsAttr = wb.Sheets("attrDICTIONARY")
    Set wsData = wb.Sheets("Sheet2")
    Set rAttr = wsAttr.Range("B2", wsAttr.Cells(wsAttr.Rows.Count, "C").End(xlUp))
    aData = wsData.Range("A2", wsData.Cells(wsData.Rows.Count, "A").End(xlUp)).Resize(, 2).Value
    ReDim aAdd(1 To 65000, 1 To UBound(aData, 2))

    For i = 1 To UBound(aData, 1)
        If WorksheetFunction.CountIfs(rAttr.Columns(1), aData(i, 1), rAttr.Columns(2), aData(i, 2)) = 0 Then
            AddIndex = AddIndex + 1
            For j = 1 To UBound(aData, 2)
                aAdd(AddIndex, j) = aData(i, j)
            Next j
        End If
    Next i

    If AddIndex > 0 Then
        rAttr.Offset(rAttr.Rows.Count).Resize(AddIndex, UBound(aAdd, 2)).Value = aAdd
        With wsAttr.Range("B2", wsAttr.Cells(wsAttr.Rows.Count, "C").End(xlUp))
            .Sort .Resize(, 1), xlAscending, .Offset(, 1).Resize(, 1), , xlAscending, Header:=xlNo
        End With
    End If

End Sub