在另一列中查找一列的元素

Question

我实现的代码比较两列，如果找到匹配的值，则将行复制在一起。

目前比较大约100-150行，大约需要三分钟，有时甚至更长。

还有比

Range.Find()

更快的方法吗？
另外，了解该方法使用的搜索算法也很有趣。

文件保存在服务器上，因此可能会增加运行时间。

我的代码的相关部分：

For Each LineA In sheet1.Range("B1:B" & LastRowSheet1)
    
    Set LineB = sheet2.Range("B1:B" & LastRowSheet2).Find(LineA.Value, LookIn:=xlValues)
    If Not LineB Is Nothing Then
        With sheet2
            .Range(.Cells(LineB.Row, 3), .Cells(LineB.Row, 12)).Copy sheet3.Range(sheet3.Cells(i, 4), sheet3.Cells(i, 13))
        End With
    
        With sheet1
            .Range(.Cells(LineA.Row, 2), .Cells(LineA.Row, 4)).Copy sheet3.Range(sheet3.Cells(i, 1), sheet3.Cells(i, 3))
        End With
        
        i = i + 1
        
   End If
   
Next LineA

Answer 1

尝试

Sub find()
Dim dataSheet As Worksheet, lookupSheet As Worksheet, resultSheet As Worksheet
Dim dataRange As Range, lookupRange As Range
Dim dataArray As Variant, lookupArray As Variant
Dim i As Long, j As Long, lastRowData As Long, lastRowLookup As Long, found As Long

Set dataSheet = ThisWorkbook.Worksheets("Sheet1")
Set lookupSheet = ThisWorkbook.Worksheets("Sheet2")
Set resultSheet = ThisWorkbook.Worksheets("Sheet3")

With dataSheet
    lastRowData = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set dataRange = .Range("B1:B" & lastRowData)
    dataArray = dataRange.Value
End With

With lookupSheet
    lastRowLookup = .Cells(.Rows.Count, "B").End(xlUp).Row
    Set lookupRange = .Range("B1:B" & lastRowLookup)
    lookupArray = lookupRange.Value
End With

i = 1

For j = 1 To UBound(dataArray, 1)
    found = Application.Match(dataArray(j, 1), lookupArray, 0)
    If Not IsError(found) Then
        resultSheet.Range("D" & i & ":M" & i).Value = lookupSheet.Range("C" & found & ":L" & found).Value
        resultSheet.Range("A" & i & ":C" & i).Value = dataSheet.Range("B" & j & ":D" & j).Value
        i = i + 1
    End If
Next j

End Sub

复制列格式

Sub CopyColumnFormats()
    Dim srcRange As Range
    Dim destRange As Range
    Dim srcCol As Range
    Dim destCol As Range
    Dim i As Long
    
    Set srcRange = ThisWorkbook.Worksheets("Sheet2").Range("C1:L1")
    Set destRange = ThisWorkbook.Worksheets("Sheet3").Range("D1:M1")
    
    For i = 1 To srcRange.Columns.Count
        Set srcCol = srcRange.Columns(i)
        Set destCol = destRange.Columns(i)
        srcCol.Copy
        destCol.PasteSpecial Paste:=xlPasteFormats
    Next i
    
    Set srcRange = ThisWorkbook.Worksheets("Sheet1").Range("B1:D1")
    Set destRange = ThisWorkbook.Worksheets("Sheet3").Range("A1:C1")

    For i = 1 To srcRange.Columns.Count
        Set srcCol = srcRange.Columns(i)
        Set destCol = destRange.Columns(i)
        srcCol.Copy
        destCol.PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
    Next i
End Sub

Answer 2

VBA 查找

Sub LookupData()
    
    Const LKP_COLUMN As Long = 1
    Const LKP_LEFT_COLUMNS_TO_EXCLUDE As Long = 1
    Const SRC_COLUMN As Long = 1
    
    ' Your code...
    
    ' These two lines are just for this code to compile.
    Const LastRowSheet2 As Long = 3 ' Lookup
    Const LastRowSheet1 As Long = 4 ' Source
    
    Dim lrg As Range: Set lrg = Sheet2.Range("B1:L" & LastRowSheet2) ' 3-12
    Dim srg As Range: Set srg = Sheet1.Range("B1:D" & LastRowSheet1) ' 2-4
    Dim dfCell As Range: Set dfCell = Sheet3.Range("A2")
    
    ' Write the values from the lookup range to an array.
    
    Dim lrCount As Long: lrCount = lrg.Rows.Count
    Dim lcCount As Long: lcCount = lrg.Columns.Count
    Dim lData(): lData = lrg.Value
    
    ' Write the unique values ('keys') and their correcesponding
    ' row indexes ('items') to a dictionary.
    
    Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
    lDict.CompareMode = vbTextCompare
    
    Dim lr As Long, lStr As String
    
    For lr = 1 To lrCount
        lStr = CStr(lData(lr, LKP_COLUMN))
        If Len(lStr) > 0 Then
            If Not lDict.Exists(lStr) Then
                lDict(lStr) = lr
            End If
        End If
    Next lr
    
    ' The source data is also...
     
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim scCount As Long: scCount = srg.Columns.Count
    
    ' ... the left part of the destination so write it to an array
    ' and resize the array to accommodate the lookup data on the right.
    
    Dim Data(): Data = srg.Value
    Dim dcCount As Long:
    dcCount = srCount + lrCount - LKP_LEFT_COLUMNS_TO_EXCLUDE
    ReDim Preserve Data(1 To srCount, 1 To dcCount)
    
    ' Loop through the source array and write the matching rows
    ' to the top of the destination array.
    
    Dim sr As Long, dr As Long, c As Long, sStr As String
    
    For sr = 1 To srCount
        sStr = Data(sr, SRC_COLUMN)
        If lDict.Exists(sStr) Then ' match found
            lr = lDict(sStr) ' retrieve the lookup row
            dr = dr + 1
            ' Write source.
            For c = 1 To scCount
                Data(sr, c) = Data(sr, c)
            Next c
            ' Write lookup.
            For c = 1 + LKP_LEFT_COLUMNS_TO_EXCLUDE To lcCount
                Data(sr, c + scCount - LKP_LEFT_COLUMNS_TO_EXCLUDE) _
                    = lData(lr, c)
            Next c
        End If
    Next sr
    
    ' Write the result from the top of the array to the range.
   
    Dim drg As Range: Set drg = dfCell.Resize(dr, dcCount)
    drg.Value = Data
    
    ' Clear below.
    drg.Resize(drg.Worksheet.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
    
    ' Inform.
    
    MsgBox "Lookup is done.", vbInformation

End Sub