Swapping Ranges in Macro

[rob51852]

Hi all,

I have a macro that 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 in Sheet2.

There are usually a few thousand values in column E but less than 30 in column Z. As a result it takes a long time to run.

I think it would be quicker if it were to loop through column Z to find matches in column E but I am a novice with VBA and don't know how to do it. I could swap the references around but then the paste offset wouldn't work.

Could anyone show me how to do it?

Thanks

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("Data")
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) '.Offset(, 10).Resize(, 7)
Err.Clear
Next c

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

End Sub

 

[DeficientOptimism]

Hi - if I am understanding you correctly - this may work:

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("Sheet1")
Set WS2 = ThisWorkbook.Sheets("Data")
Set Rng1 = WS1.Range(WS1.Range("Z5"), WS1.Range("Z" & Rows.Count).End(xlUp))
Set Rng2 = WS2.Range(WS2.Range("E2"), WS2.Range("E" & Rows.Count).End(xlUp))

For Each c In Rng1
On Error Resume Next
Rng2.Find(What:=c).Offset(, 19).Copy Destination:=c.Offset(, 1)
Err.Clear
Next c

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