# Copy and Paste Macro Containing For Loop

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

• Welcome to Code Review! Please edit your question so that the title describes the purpose of the code, rather than its mechanism. We really need to understand the motivational context to give good reviews. It's best to describe what value this code provides to its user. Jan 24 at 12:45
• Could you give a small before and after snippet? So for every ID in Sheet1.colE, you check if that ID is in Sheet2.colZ, if so you take the corresponding value from Sheet2.colAA and copy it to Sheet1.colP? Also why are you using VBA rather than some kind of Lookup formula in excel? Is your data formatted as an Excel table/can it be? You can paste tables from excel to markdown and add them directly to your post thisdavej.com/copy-table-in-excel-and-paste-as-a-markdown-table Jan 24 at 14:51
• Hi @Greedo, your understanding is correct except that it is colZ in Sheet1 and colE in Sheet2. I have added some snippets to the post. For various reasons I can't use formulas or tables. Thanks Jan 24 at 16:06
• You wrote : There are usually a few thousand values in column E but less than 30 in column Z ---> I wonder if there is a reason that instead of using the value in sheet1 column Z if it's found in sheet2 column E, you use the value in sheet2 column E if it's found in sheet1 column Z ? I ask because in your code there is no something like this : if this looped cell value is found in column Z then do blablabla, if this looped cell value is not found in column Z then do blublublu to this looped cell value. Jan 25 at 2:42
• So, maybe something like this ? for each c in Rng2: c.offset(0,1).copy destination:= Rng1.cells.find(c.value).offset(0,19) ---> this will loop to the "less than 30" data in sheet1 column Z, copy the looped cell.offset(0,1) value then paste to the found looped cell.offset(0,19) in sheet2 column E. Not tested. Jan 25 at 2:54

# 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

• this is amazing, thank you. It will take some time for me to digest! Much appreciated. Feb 1 at 8:17
• This works perfectly. I have also learned a lot. Thanks once again. Feb 3 at 14:16