Question

我有两个公司名称列（A＆amp; B）＆amp;城市。我还有另外两列（D＆amp; E）。如果在D＆amp; E的任何行中不存在某一行A＆amp; B，则我需要将该行的A＆amp; B添加到列D＆amp; E的末尾。所以基本上匹配，如果没有匹配则添加。 A＆amp; B中约有550行数据，D＆amp; E中有6000行数据。对于循环需要73和StrComp 357秒。这只是一个文件，我有几千个这样的文件。 StrComp基于 - In Excel 2010 compare data from columns and highlight values if different using macro and VBA。我在Fast compare method of 2 columns以mehow方式尝试了数组方法 - 它非常快 - 目前将A列与D列进行比较，并在1秒内在D列的末尾附加。一直在努力修改它以进行2列（A＆amp; B）到2列（D＆amp; E）匹配很长一段时间......我错过了一些相当简单的东西还是这太复杂了？非常感谢任何帮助...... 代码我想修改 -

Sub CompareAddArr()
    Application.ScreenUpdating = False

    Dim stNow As Date
    stNow = Now

    Dim arr As Variant
    arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
    Dim varr As Variant
    Set varr = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).Value
    Dim x, y, match As Boolean
    For Each x In arr
    match = False
    For Each y In varr
    If x = y Then match = True  'this matches colA with colD - 1col-1col
    'here need something like - if x = y and a = b Then match = True (for ColB with ColE) 
    Next y
    If Not match Then
    Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1) = x
    'here need something like - Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1) = a
    End If
    Next

    Application.ScreenUpdating = True
    MsgBox DateDiff("s", stNow, Now)
End Sub

Answer 1

要修改此代码，您应该：

使用Worksheet变量。这样，您的代码就不会绑定到ActiveSheet
将每个范围的两列都放入Variant Arrays
循环遍历数组，比较每行中的两个项目
找到匹配项时提前退出内部循环
累积数据以复制到另一个Variant数组中（这样可以避免访问每个结果的工作表）

在循环结束时一次性复制生成的新数据

Sub CompareAddArr()
    Dim arr As Variant
    Dim varr As Variant
    Dim x, y, match As Boolean
    Dim i As Long, j As Long
    Dim InsertRow As Long
    Dim Newdata As Variant
    Dim ws As Worksheet

    Set ws = ActiveSheet

    With ws
        arr = Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp)).Value
        varr = Range(.Cells(2, 5), .Cells(.Rows.Count, 4).End(xlUp)).Value
        InsertRow = 1
        ReDim Newdata(1 To 2, 1 To UBound(arr, 1))

        For i = 1 To UBound(arr, 1)
            match = False
            For j = 1 To UBound(varr, 1)
                If arr(i, 1) = varr(j, 1) And arr(i, 2) = varr(j, 2) Then
                    match = True
                    Exit For
                End If
            Next
            If Not match Then
                Newdata(1, InsertRow) = arr(i, 1)
                Newdata(2, InsertRow) = arr(i, 2)
                InsertRow = InsertRow + 1
                'Like LR = LR + 1, how can I increment UBound(varr, 1) by 1 here
            End If
        Next
        If InsertRow > 1 Then
            ReDim Preserve Newdata(1 To 2, 1 To InsertRow - 1)
            .Range("D2:E2").Offset(UBound(varr, 1)).Resize(UBound(Newdata, 2), 2).Value = _
              Application.Transpose(Newdata)
        End If
    End With
End Sub

更新 - 新要求，仅添加一次唯一条目

要仅在arr添加记录时添加记录，请测试Newdata数组，并且仅当该数组不在该数组中时才添加。

我还添加了一个参数来指定要处理的列数和相应的代码

Sub CompareAddArrUnique()
    Dim arr As Variant
    Dim varr As Variant
    Dim match As Boolean
    Dim i As Long, j As Long
    Dim InsertRow As Long
    Dim Newdata As Variant
    Dim ws As Worksheet
    Dim NumberOfColumns As Long
    Dim col As Long

    Set ws = ActiveSheet

    NumberOfColumns = 2
    With ws
        arr = Range(.Cells(2, NumberOfColumns), .Cells(.Rows.Count, 1).End(xlUp)).Value
        varr = Range(.Cells(2, 4 + NumberOfColumns - 1), .Cells(.Rows.Count, 4).End(xlUp)).Value
        InsertRow = 1
        ReDim Newdata(1 To NumberOfColumns, 1 To UBound(arr, 1))

        For i = 1 To UBound(arr, 1)
            match = False
            For j = 1 To UBound(varr, 1) ' <---
                match = True
                For col = 1 To NumberOfColumns ' <---
                    match = match And (arr(i, col) = varr(j, col))
                    If Not match Then Exit For
                Next
                If match Then Exit For
            Next
            If Not match Then
                For j = 1 To InsertRow - 1
                    match = True
                    For col = 1 To NumberOfColumns
                        match = match And (arr(i, col) = Newdata(col, j))
                        If Not match Then Exit For
                    Next
                    If match Then Exit For
                Next
            End If
            If Not match Then
                For j = 1 To NumberOfColumns
                    Newdata(j, InsertRow) = arr(i, j)
                Next
                InsertRow = InsertRow + 1
            End If
        Next
        If InsertRow > 1 Then
            ReDim Preserve Newdata(1 To 2, 1 To InsertRow - 1)
            .Range("D2:E2").Offset(UBound(varr, 1)).Resize(UBound(Newdata, 2), 2).Value = _
              Application.Transpose(Newdata)
        End If
    End With
End Sub

如何使用数组方法将2个单元格的值与2个其他单元格的值进行比较？

1 个答案: