how do i make this following vlookup code run faster-CodePudding

 Sub Rectangle1_Click()
 Dim i, j, lastG, lastD As Long
 Set ws = Worksheets("sheet2")
 With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
 End With



  ' find last row
 lastG = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row

 lastD = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row

 ' loop over values in "sheet2"
 For i = 2 To lastG
     lookupVal = Sheets("sheet2").Cells(i, "A") ' value to find

' loop over values in "sheet1"
For j = 2 To lastD
    currVal = Sheets("sheet1").Cells(j, "A")

    If lookupVal = currVal Then
        Sheets("sheet2").Cells(i, "B") = Sheets("sheet1").Cells(j, "t")
        Sheets("sheet2").Cells(i, "C") = Sheets("sheet1").Cells(j, "u")
        Sheets("sheet2").Cells(i, "D") = Sheets("sheet1").Cells(j, "v")
         Sheets("sheet2").Cells(i, "E") = Sheets("sheet1").Cells(j, "b")
        Sheets("sheet2").Cells(i, "f") = Sheets("sheet1").Cells(j, "c")
        Sheets("sheet2").Cells(i, "g") = Sheets("sheet1").Cells(j, "ap")
         Sheets("sheet2").Cells(i, "h") = Sheets("sheet1").Cells(j, "g")
        Sheets("sheet2").Cells(i, "i") = Sheets("sheet1").Cells(j, "j")
        Sheets("sheet2").Cells(i, "j") = Sheets("sheet1").Cells(j, "l")
         Sheets("sheet2").Cells(i, "k") = Sheets("sheet1").Cells(j, "m")
        Sheets("sheet2").Cells(i, "l") = Sheets("sheet1").Cells(j, "n")
       

    Exit For
    End If
   Next j
  Next i



 On Error Resume Next


 With Application

.EnableEvents = True
.CutCopyMode = True
.ScreenUpdating = True
 End With
 End Sub

i have tried everything but this isnt working well for large data set. code looks for the value in sheet1 in sheet 2 and returns corresponding values in columns, it works very slow for large data set. code works with with fewer data in, however it takes ages for larger data sets, any help in this is much appriciated.thank you

CodePudding user response：

Matching in VBA will be much faster if you limit the interactions with the sheet to "get data" in an Array, "write" transformed Array back to the sheet. Arrays will store the data, a "dictionary" will allow you to match. This example should get you on the right track. Try to adapt it to your need and post back if you get stuck:

Option Explicit
    'always add this to your code
    'it will help you to identify non declared (dim) variables
    'if you don't dim a var in vba it will be set as variant wich will sooner than you think give you a lot of headaches
    
Sub DictMatch()
    'Example of match using dictionary late binding
    'Sourcesheet = sheet1
    'Targetsheet = sheet2
    'colA of sh1 is compared with colA of sh2
    'if we find a match, we copy colB of sh1 to the end of sh2
    
    '''''''''''''''''
    'Set some vars and get data from sheets in arrays
    '''''''''''''''''
        'as the default is variant I don't need to add "as variant"
        Dim arr, arr2, arr3, j As Long, i As Long, dict As Object
        
        'when creating a dictionary we can use early and late binding
        'early binding has the advantage to give you "intelisence"
        'late binding on the other hand has the advantage you don't need to add a reference (tools>references)
        Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
    
        dict.CompareMode = 1 'textcompare
        arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source, assuming we have data as of A1
        arr2 = Sheet2.Range("A1").CurrentRegion.Value2 'load source2, assuming we have data as of A1
    
    '''''''''''''''''
    'Loop trough source, calculate and save to target array
    '''''''''''''''''
    'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
    'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
    'we can write these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
    'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
    'so we'll use an intermediant array (arr3) to store the results
            
    'We use a "dictionary" to match values in vba because this allows to easily check the existance of a value
    'Toghether with arrays and collections these are probably the most important features to learn in vba!
        For j = 1 To UBound(arr) 'traverse source, ubound allows to find the "lastrow" of the array
            If Not dict.Exists(arr(j, 1)) Then 'Check if value to lookup already exists in dictionary
                dict.Add Key:=arr(j, 1), Item:=arr(j, 1) 'set key if I don't have it yet in dictionary
            End If
        Next j 'go to next row. in this simple example we don't travers multiple columns so we don't need a second counter (i)
    
    'Before I can add values to a variant array I need to redim it. arr3 is a temp array to store matching col
    '1 To UBound(arr2) = the number of rows, as in this example we'll add the match as a col we just keep the existing nr of rows
    '1 to 1 => I just want to add 1 column but you can basically retrieve as much cols as you want
        ReDim arr3(1 To UBound(arr2), 1 To 1)
        For j = 1 To UBound(arr2) 'now that we have all values to match in our dictionary, we traverse the second source
            If dict.Exists(arr2(j, 1)) Then 'matching happens here, for each value in col 1 we check if it exists in the dictionary
                arr3(j, 1) = arr(j, 2) 'If a match is found, we add the value to find back, in this example col. 2, and add it to our temp array (arr3).
                'arr3(j, 2) = arr(j, 3) 'As explained above, we could retrieve as many columns as we want, if you only have a few you would add them manually like in this example but if you have many we could even add an additional counter (i) to do this.
            End If
        Next j 'go to the next row
    
    '''''''''''''''''
    'Write to sheet only at the end, you could add formating here
    '''''''''''''''''
        With Sheet2 'sheet on which I want to write the matching result
            'UBound(arr2, 2) => ubound (arr2) was the lastrow, the ubound of the second dimension of my array is the lastcolumn
            '.Cells(1, UBound(arr2, 2)   1) = The startcel => row = 1, col = nr of existing cols   1
            '.Cells(UBound(arr2), UBound(arr2, 2)   1)) = The lastcel => row = number of existing rows, col = nr of existing cols   1
            .Range(.Cells(1, UBound(arr2, 2)   1), .Cells(UBound(arr2), UBound(arr2, 2)   1)).Value2 = arr3 'write target array to sheet
        End With
End Sub

CodePudding user response：

Use Match

Option Explicit
Sub macro1()
   
   Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
   Dim LastRow As Long, r As Long, n As Long, i As Integer
   Dim ar1, ar2, arCol, v, t0 As Single
   t0 = Timer
   
   Set wb = ThisWorkbook
   Set ws1 = wb.Sheets("Sheet1")
   With ws1
       LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
       ar1 = .Range("A1:A" & LastRow)
   End With
   
   arCol = Array("T", "U", "V", "B", "C", "AP", "G", "J", "L", "M", "N")
   
   Application.ScreenUpdating = False
   Set ws2 = wb.Sheets("Sheet2")
   With ws2
       LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
       For r = 2 To LastRow
          v = Application.Match(.Cells(r, "A"), ar1, 0)
          If Not IsError(v) Then
              For i = 0 To UBound(arCol)
                  ws2.Cells(r, i   2) = ws1.Cells(v, arCol(i))
              Next
              n = n   1
          End If
       Next
   End With
   Application.ScreenUpdating = True

   MsgBox n & " matches", vbInformation, Format(Timer - t0, "0.0 secs")

End Sub