Fastest Way to find elements of one column in another VBA

A part of an algorithm I implemented compares two columns of different lists and essentially copies the lines together if it finds matching values, and I want to know the fastest way to do this.
Currently, it compares about 100-150 lines with each other and it takes around 3 minutes, sometimes more, which I feel is pretty horrendous.
This brought up the question, if there is any faster method than Range.Find(), also it would be interesting to know what search algorithm this method is using.

I am fairly new to VBA and started using it out of necessity, I am a working student and come from c/# and python, so I am by no means an expert, maybe my expectations are just too high.. File is saved on a server so that may increase the runtime, but I am not sure by how much that factors in.

The relevant part of my code looks like this:

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
(changed variable names from my code, so if something doesn't make sense, tell me)

</details>


# 答案1
**得分**: 1

以下是您提供的代码的中文翻译：

```vba
尝试

    子 查找()
    Dim 数据表 As 工作表，查找表 As 工作表，结果表 As 工作表
    Dim 数据范围 As 范围，查找范围 As 范围
    Dim 数据数组 As 变体，查找数组 As 变体
    Dim i As 长整型，j As 长整型，最后一行数据 As 长整型，最后一行查找 As 长整型，找到 As 长整型
    
    设置 数据表 = 这工作簿.工作表("Sheet1")
    设置 查找表 = 这工作簿.工作表("Sheet2")
    设置 结果表 = 这工作簿.工作表("Sheet3")
    
    与 数据表
        最后一行数据 = .单元格(.行数, "B").End(xlUp).行
        设置 数据范围 = .范围("B1:B" & 最后一行数据)
        数据数组 = 数据范围.值
    结束与
    
    与 查找表
        最后一行查找 = .单元格(.行数, "B").End(xlUp).行
        设置 查找范围 = .范围("B1:B" & 最后一行查找)
        查找数组 = 查找范围.值
    结束与
    
    i = 1
    
    对于 j = 1 到 UBound(数据数组, 1)
        找到 = 应用程序.匹配(数据数组(j, 1), 查找数组, 0)
        如果 不是错误找到 然后
            结果表.范围("D" & i & ":M" & i).值 = 查找表.范围("C" & 找到 & ":L" & 找到).值
            结果表.范围("A" & i & ":C" & i).值 = 数据表.范围("B" & j & ":D" & j).值
            i = i + 1
        结束如果
    下一 j
    
    结束子

复制列格式

    子 复制列格式()
        Dim 源范围 As 范围
        Dim 目标范围 As 范围
        Dim 源列 As 范围
        Dim 目标列 As 范围
        Dim i As 长整型
        
        设置 源范围 = 这工作簿.工作表("Sheet2").范围("C1:L1")
        设置 目标范围 = 这工作簿.工作表("Sheet3").范围("D1:M1")
        
        对于 i = 1 到 源范围.列数
            设置 源列 = 源范围.列(i)
            设置 目标列 = 目标范围.列(i)
            源列.复制
            目标列.粘贴特殊 粘贴:=xlPasteFormats
        下一 i
        
        设置 源范围 = 这工作簿.工作表("Sheet1").范围("B1:D1")
        设置 目标范围 = 这工作簿.工作表("Sheet3").范围("A1:C1")
    
        对于 i = 1 到 源范围.列数
            设置 源列 = 源范围.列(i)
            设置 目标列 = 目标范围.列(i)
            源列.复制
            目标列.粘贴特殊 粘贴:=xlPasteFormats
            应用程序.剪切复制模式 = 假
        下一 i
    结束子

希望这对您有所帮助。如果您需要进一步的帮助，请随时提出。

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

答案2

得分: 0

以下是VBA代码的中文翻译：

' VBA查找
'
' [![输入图像描述][1]][1]
'
'<!-- 语言：lang-vb -->
'
Sub 查找数据()

    Const LKP_COLUMN As Long = 1
    Const LKP_LEFT_COLUMNS_TO_EXCLUDE As Long = 1
    Const SRC_COLUMN As Long = 1
    
    ' 你的代码...
    
    ' 这两行仅用于使此代码编译。
    Const LastRowSheet2 As Long = 3 ' 查找
    Const LastRowSheet1 As Long = 4 ' 源
    
    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")
    
    ' 将查找范围的值写入数组。
    
    Dim lrCount As Long: lrCount = lrg.Rows.Count
    Dim lcCount As Long: lcCount = lrg.Columns.Count
    Dim lData(): lData = lrg.Value
    
    ' 将唯一值（'键'）及其对应的行索引（'项目'）写入字典。
    
    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
    
    ' 源数据也是...
     
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim scCount As Long: scCount = srg.Columns.Count
    
    ' ...目标的左侧部分，因此将其写入数组
    ' 并调整数组大小以容纳右侧的查找数据。
    
    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)
    
    ' 遍历源数组并将匹配行写入目标数组的顶部。
    
    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 ' 找到匹配项
            lr = lDict(sStr) ' 检索查找行
            dr = dr + 1
            ' 写入源。
            For c = 1 To scCount
                Data(sr, c) = Data(sr, c)
            Next c
            ' 写入查找。
            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
    
    ' 从数组顶部将结果写入范围。
   
    Dim drg As Range: Set drg = dfCell.Resize(dr, dcCount)
    drg.Value = Data
    
    ' 清除下方。
    drg.Resize(drg.Worksheet.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
    
    ' 通知。
    
    MsgBox "查找完成。", vbInformation

End Sub

注意：上述翻译只包括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