lookup and compare/copy between 2 workbooks

Rip1971

Board Regular
Joined
Nov 3, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Hi there,

I have code to lookup an ID in one sourceworkbook compare that with an ID in destination workbook and then copy a cell value from source to destination.
However when i have a large file/list (5000+ rows in source and 250000+ row in destination) this looping of looking for and copying takes very long.
Who can give me same results but in a faster manner.


VBA Code:
Sub CopyPloegPU(control As IRibbonControl)
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, ID As Range, fnd As Range, sAddr As String
    Set srcWS = Workbooks("Adressenlijst_PU_ID10331.xlsx").Sheets("Adressenlijst")
    Set desWS = ActiveWorkbook.Sheets("Data")
    With srcWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For Each ID In .Range("A2:A" & LastRow)
            Set fnd = desWS.Range("A:A").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                sAddr = fnd.Address
                Do
                    desWS.Range("T" & fnd.Row) = ID.Offset(, 1)
                    Set fnd = desWS.Range("A:A").FindNext(fnd)
                Loop While fnd.Address <> sAddr
            End If
            sAddr = ""
    
    Next ID
    End With
    Application.ScreenUpdating = True
End Sub
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,264
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
How about
VBA Code:
Sub CopyPloegPU(control As IRibbonControl)
   Application.ScreenUpdating = False
   Dim LastRow As Long, r As Long
   Dim srcWS As Worksheet, desWS As Worksheet
   Dim Ary As Variant, Nary As Variant
   Set srcWS = Workbooks("Adressenlijst_PU_ID10331.xlsx").Sheets("Adressenlijst")
   Set desWS = ActiveWorkbook.Sheets("Data")
 
   With srcWS
      LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      Ary = .Range("A2:B" & LastRow).Value2
   End With
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         .Item(Ary(r, 1)) = Ary(r, 2)
      Next r
      LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      Ary = desWS.Range("A2:A" & LastRow).Value2
      Nary = desWS.Range("T2:T" & LastRow).Value2
      For r = 1 To UBound(Ary)
         If .Exists(Ary(r, 1)) Then Nary(r, 1) = .Item(Ary(r, 1))
      Next r
   End With
   desWS.Range("T2").Resize(UBound(Nary)).Value = Nary
   Application.ScreenUpdating = True
End Sub
EDIT:
Corrected typo in sheet variable
 
Last edited:
Solution

Rip1971

Board Regular
Joined
Nov 3, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
How about
VBA Code:
Sub CopyPloegPU(control As IRibbonControl)
   Application.ScreenUpdating = False
   Dim LastRow As Long, r As Long
   Dim srcWS As Worksheet, desWS As Worksheet
   Dim Ary As Variant, Nary As Variant
   Set srcWS = Workbooks("Adressenlijst_PU_ID10331.xlsx").Sheets("Adressenlijst")
   Set desWS = ActiveWorkbook.Sheets("Data")
  
   With srcWS
      LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      Ary = .Range("A2:B" & LastRow).Value2
   End With
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         .Item(Ary(r, 1)) = Ary(r, 2)
      Next r
      LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      Ary = desWS.Range("A2:A" & LastRow).Value2
      Nary = desWS.Range("T2:T" & LastRow).Value2
      For r = 1 To UBound(Ary)
         If .Exists(Ary(r, 1)) Then Nary(r, 1) = .Item(Ary(r, 1))
      Next r
   End With
   destws.Range("T2").Resize(UBound(Nary)).Value = Nary
   Application.ScreenUpdating = True
End Sub
When i run this code i get an error in the following line

destws.Range("T2").Resize(UBound(Nary)).Value = Nary

and nothing is copied to destination file.
 

Rip1971

Board Regular
Joined
Nov 3, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Maybe extra information that may help.
The source file has unique set of ID's but the destination has multiple of the same ID's

regards
Rip
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,264
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I misspelt the sheet variable, it should be desWS
 

Rip1971

Board Regular
Joined
Nov 3, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
I misspelt the sheet variable, it should be desWS
I looked over that multiple time and did not see it. This code works a lot faster
thanks you for quick response.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,264
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

You're welcome & thanks for the feedback.
 

Rip1971

Board Regular
Joined
Nov 3, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
I have 1 question. since i would like to use this in different situations now.
How can i change source column that compares with destination column

ie. now column A looked at A and copied B
what if source is setup that B compared to F and copied A

what changes do i have to make to do that. in my code i changed the offset.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,264
Office Version
  1. 365
Platform
  1. Windows
Just to check you want to compare col B from src to col F on des?
 

Rip1971

Board Regular
Joined
Nov 3, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Just to check you want to compare col B from src to col F on des?
correct. source B to compare with destination F. and then copy source A to specific column. i used the same code for that but used offset to make sure the right value was copied

VBA Code:
Sub CopyPriority(control As IRibbonControl)
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, ID As Range, fnd As Range, sAddr As String
    Set srcWS = Workbooks("Prioriteitenlijst.xlsb").Sheets("Overzicht")
    Set desWS = ActiveWorkbook.Sheets("Data")
    With srcWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For Each ID In .Range("B2:B" & LastRow)
            Set fnd = desWS.Range("F:F").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                sAddr = fnd.Address
                Do
                    desWS.Range("K" & fnd.Row) = ID.Offset(, -1)
                    Set fnd = desWS.Range("F:F").FindNext(fnd)
                Loop While fnd.Address <> sAddr
            End If
            sAddr = ""
    
    Next ID
    End With
    Application.ScreenUpdating = True
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,127,035
Messages
5,622,332
Members
415,894
Latest member
silverhaze

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top