lookup and compare/copy between 2 workbooks

[Rip1971]

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.

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

 

[Fluff]

Hi & welcome to MrExcel.
How about

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

 

[Rip1971]

Hi & welcome to MrExcel.
How about

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]

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]

I misspelt the sheet variable, it should be desWS

 

[Rip1971]

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]

You're welcome & thanks for the feedback.

 

[Rip1971]

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]

Just to check you want to compare col B from src to col F on des?

 

[Rip1971]

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

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