Copy and Paste Macro Containing For Loop

Question

The macro below loops through column E in Sheet2 and finds matches in column Z of Sheet1. If a match is found it copies the value on the same row contained in column AA.

It works ok but hangs when it runs. There are usually a few thousand values in column E but less than 30 in column Z.

I've run it on a few PCs with decent specs but always have the same issue.

Are there any ways to optimise it?

Example Data:

Sheet1, column Z:

Z
42039505
40642035
40191591
23239795
38593074

Sheet1, column AA:

AA
0
1
R
E
8

Sheet2, column E

E
42039505
40642035
40191591
23239795
38593074
42039505
40642035
40191591
23239795
38593074
42039505
40642035
40191591
23239795
38593074

Sub CopyResult()

Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim Rng1 As Range
Dim Rng2 As Range
Dim c As Range
    
Application.ScreenUpdating = False

Set WS1 = ThisWorkbook.Sheets("Sheet2")
Set WS2 = ThisWorkbook.Sheets("Sheet1")
Set Rng1 = WS1.Range(WS1.Range("E2"), WS1.Range("E" & Rows.Count).End(xlUp))
Set Rng2 = WS2.Range(WS2.Range("Z5"), WS2.Range("Z" & Rows.Count).End(xlUp))

For Each c In Rng1
On Error Resume Next

Rng2.Find(What:=c).Offset(, 1).Copy Destination:=c.Offset(, 19) 
Err.Clear
Next c

Set WS1 = Nothing
Set WS2 = Nothing
Set Rng1 = Nothing
Set Rng2 = Nothing
Application.ScreenUpdating = True

End Sub

Answer 1

A Classic VBA Lookup

Pros

• First of all, congratulations, the code compiles which could indicate that you understand the importance of Option Explicit.
• Mostly you understand the importance of qualifying objects which includes qualifying the worksheets which you do with ThisWorkbook, the workbook containing this code.
• You are correctly looping through column E of the destination worksheet Sheet2 that has a ton of duplicates, to lookup values in column Z of the source worksheet Sheet1 that should have unique (distinct) values.
• You are not lazy to use Next without the control variable c.

Cons

• Using variables like WS1 and WS2 is bad practice i.e. already in a day or two, it won't be so easy to determine which one is the source and which one the destination worksheet not to mention the additional confusion you introduced by using WS1 for Sheet2 and WS2 for Sheet1.

• There is no room for On Error Resume Next when using the Find method. Also, the prescribed way to use it is:

  On Error Resume Next
  Whatever
  On Error Goto 0
  

• Adding another variable and testing it against Nothing is the way to go. Also, copying by assignment is faster then using the Copy method.

  Dim sCell As Range
  
  For Each c In Rng1.Cells
      Set sCell = Rng2.Find(...)
      If Not sCell Is Nothing Then
          c.Offset(...).Value = sCell.Offset(...).Value 
      End If
  Next  
  

• What are you looping through? Through cells. So use ... In Rng1.Cells.

• Using offset in this way is bad practice. Sure, everyone immediately knows the column adjacent to the right of column Z but I don't think that anyone will instantly know that 19 columns to the right of column E is column X.

• The Find method has many more arguments so you should utilize them, in this case especially the 4th argument, the LookAt argument with the parameter xlWhole or xlPart which is saved each time the Find method is used.

• The series of lines Set Whatever = Nothing are totally redundant and they gotta go.

Nit Picking

• You are not using constants.
• You have put the variable declarations at the beginning, far from the action. I prefer to have them closer, and since there will be more than a dozen of them in my code, I wouldn't want that wall of variables at the beginning of my code.
• I prefer to use a variable for the workbook even if it is ThisWorkbook so in the case I would want to use a different workbook, I would have to change it only in one place.
• I would put Application.ScreenUpdating = False right before the loop indicating that this is where the action begins.
• You haven't qualified the Rows in Rows.Count e.g.: WS1.Rows.Count.

Status

• The bottleneck is that you're looping through tens of thousands of cells in the destination lookup column. You can't turn off enough settings for it to not take forever to finish.
• The use of Application.Match instead of the Find method would increase efficiency a bit but I won't go down that road since it won't make enough of a difference.

The Plan

• In the source worksheet (Sheet1), write the values from the lookup column (Z) and the corresponding values, the values in the same row, from the return column (AA) to arrays, loop through the arrays and write the lookup values to the keys, and the return values to the items of a dictionary. Erase the arrays.
• In the destination worksheet (Sheet2), write the values from the lookup column (E) to another array and use yet another array of the same size to write the matches to it. Then write the matches to the return column (X).
• Use a message box to not wonder if the code has run or not since it is 'lightning' fast.

The Main Procedure

Option Explicit

Sub LookupData()

    Const SRC_NAME As String = "Sheet1"
    Const SRC_FIRST_LOOKUP_CELL As String = "Z5"
    Const SRC_RETURN_COL As String = "AA"
    Const DST_NAME As String = "Sheet2"
    Const DST_FIRST_LOOKUP_CELL As String = "E2"
    Const DST_RETURN_COL As String = "X"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    ' The `Find` or the `End` method would fail if the worksheet were filtered.
    If sws.FilterMode Then sws.ShowAllData
    
    Dim sfCell As Range: Set sfCell = sws.Range(SRC_FIRST_LOOKUP_CELL)
    
    Dim slrg As Range: Set slrg = RefColumn(sfCell)
    If slrg Is Nothing Then Exit Sub ' no data in column range
    Dim slData(): slData = GetSingleColumnRange(slrg)
    
    Dim srrg As Range: Set srrg = slrg.EntireRow.Columns(SRC_RETURN_COL)
    Dim srData(): srData = GetSingleColumnRange(srrg)
    
    Dim dict As Object: Set dict = DictTwoSingleColumns(slData, srData)
    If dict Is Nothing Then Exit Sub ' only error values and blanks
    
    Erase slData
    Erase srData
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    ' The `Find` or the `End` method would fail if the worksheet were filtered.
    If dws.FilterMode Then dws.ShowAllData
    
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_LOOKUP_CELL)
    
    Dim dlrg As Range: Set dlrg = RefColumn(dfCell)
    If dlrg Is Nothing Then Exit Sub ' no data in column range
    Dim dlData(): dlData = GetSingleColumnRange(dlrg)
    
    Dim drData(): drData = GetLookedUpColumnInDict(dlData, dict)
    Dim drrg As Range: Set drrg = dlrg.EntireRow.Columns(DST_RETURN_COL)
    drrg.Value = drData
    
    MsgBox "Data looked up.", vbInformation

End Sub

The Help

• Note that the last two procedures aren't as flexible as the first two i.e. their parameters are restricted to 2D single-column column arrays while the last is additionally restricted to a one-based array. The keys of the dictionary are values converted to strings and in the last procedure, the lookup values are converted to strings.

Reference a Single Column Range

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      References the range from a given cell to the bottom-most
'               non-empty cell in same column.
' Remarks:      It will fail if the worksheet is filtered.
'               It will not fail if the worksheet has hidden rows or columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    Dim rg As Range
    With FirstCell.Cells(1)
        Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not rg Is Nothing Then Set rg = .Resize(rg.Row - .Row + 1)
    End With
    If Not rg Is Nothing Then Set RefColumn = rg
End Function

Single Column Range To Array

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a given column of a range
'               in a 2D one-based single-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSingleColumnRange( _
    ByVal rg As Range, _
    Optional ByVal ColumnNumber As Long = 1) _
As Variant
    If ColumnNumber < 1 Then Exit Function
    If ColumnNumber > rg.Columns.Count Then Exit Function
    Dim Data()
    With rg.Areas(1).Columns(ColumnNumber)
        Dim rCount As Long: rCount = .Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    GetSingleColumnRange = Data
End Function

Source Lookup and Return Values To Dictionary

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a given 2D one-based
'               single-column array, converted to strings, in the 'keys',
'               and the corresponding values, the values in the same rows
'               of another given same sized array, not converted to strings,
'               in the 'items' of a dictionary.
' Remarks:      Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictTwoSingleColumns( _
    DataKeys() As Variant, _
    DataItems() As Variant) _
As Object

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim Key As Variant
    Dim r As Long
    
    For r = LBound(DataKeys, 1) To UBound(DataKeys, 1)
        Key = DataKeys(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(CStr(Key)) > 0 Then ' exclude blanks
                dict(CStr(Key)) = DataItems(r, 1)
            End If
        End If
    Next r
   
    If dict.Count = 0 Then Exit Function ' only error values and blanks
    
    Set DictTwoSingleColumns = dict

End Function

Return Values From Dictionary To Array

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      From a given dictionary, returns the corresponding looked up
'               values, converted to strings, of a given 2D one-based
'               single-column array, in another same-sized array.
' Remarks:      The 'keys' of the dictionary need also to be strings while
'               the 'items' can be simple variants (not objects or arrays).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetLookedUpColumnInDict( _
    Data() As Variant, _
    ByVal dict As Object) _
As Variant()
    Dim dData(): ReDim dData(1 To UBound(Data, 1), 1 To 1)
    Dim r As Long, rString As String
    For r = 1 To UBound(Data, 1)
        rString = CStr(Data(r, 1))
        If Len(rString) > 0 Then
            If dict.Exists(rString) Then dData(r, 1) = dict(rString)
        End If
    Next r
    GetLookedUpColumnInDict = dData
End Function