Question

我在Excel中有2个表。需要根据工作表2更新attrDICTIONARY中的itemx，attributex。

我想浏览Sheet 2中的每个itemx，attributex
如果在attrDICTIONARY中找不到，请在

注意：这些列按itemx按字母顺序A-Z排序。工作表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

由于表是排序的，我只是检查它们是否相同，如果不是在上面添加一行并添加适当的值。

此代码可用到大约40万件物品。此时，似乎代码停止检查重复项，只是为所有内容添加新行，将原始值下移到底部并创建重复项。我使用不同颜色的字体检查了新项目。

任何帮助将不胜感激。谢谢。

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

如果2对单元格不相等，请在VBA中执行某些操作

1 个答案: