Find elements of one column in another

Question

Code I implemented compares two columns and copies the lines together if it finds matching values.

Currently, it compares about 100-150 lines and it takes around three minutes, sometimes more.

Is there is any faster method than Range.Find()?
Also it would be interesting to know what search algorithm this method is using.

File is saved on a server so that may increase the runtime.

The relevant part of my code:

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

try

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

to copy column format

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