lookup and compare/copy between 2 workbooks

Rip1971

Board Regular
Joined
Nov 3, 2020
Messages
65
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
 
Ok, you would need to make these changes
Rich (BB code):
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         .Item(Ary(r, 2)) = Ary(r, 1)
      Next r
      LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      Ary = desWS.Range("F2:F" & LastRow).Value2
      Nary = desWS.Range("K2:K" & 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("K2").Resize(UBound(Nary)).Value = Nary
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Ok, you would need to make these changes
Rich (BB code):
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         .Item(Ary(r, 2)) = Ary(r, 1)
      Next r
      LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      Ary = desWS.Range("F2:F" & LastRow).Value2
      Nary = desWS.Range("K2:K" & 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("K2").Resize(UBound(Nary)).Value = Nary
Oke, i figured it out now what part does the same as what i did with offset. i tried it on several occasions with different file layout so i know what i can adjust to get the right result.
Thank you for your help in this matter

Rip
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,952
Members
448,535
Latest member
alrossman

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
Back
Top