A faster alternative to my vlookup block of code?

Question

Sheets 'kw30', 'kw60', and 'kw90' are about 20k lines. sheet 'bulkexport' is about 300k lines.

This section alone takes about 20 minutes to execute.

Is there a faster way to approach this or restructure it? I was trying to think of a way to break the bottom third with the 'bulkexport' sheet into multiple sections so that vlookup is only looking at small portions at a time...

Any input is appreciated.

Thanks!! DW

    Sheets("kw90").Select
    For i = 2 To kw90rowcount
        On Error Resume Next

        
        Range("ac" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:y" & kw60rowcount), 2, False)
        Range("ad" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:z" & kw60rowcount), 3, False)
        Range("ae" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:aa" & kw60rowcount), 4, False)
        Range("ai" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:ab" & kw60rowcount), 5, False)
        Range("aj" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw60").Range("x2:ac" & kw60rowcount), 6, False)
        
        Range("af" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:y" & kw30rowcount), 2, False)
        Range("ag" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:z" & kw30rowcount), 3, False)
        Range("ah" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:aa" & kw30rowcount), 4, False)
        Range("ak" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:ab" & kw30rowcount), 5, False)
        Range("al" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("kw30").Range("x2:ac" & kw30rowcount), 6, False)
        
        
        Range("y" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("ac2:ad" & bulkexportrowcount), 2, False)
        Range("z" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("ad2:ae" & bulkexportrowcount), 3, False)
        Range("aa" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("ae2:af" & bulkexportrowcount), 4, False)
        Range("ab" & i).Value = Application.WorksheetFunction.VLookup(Range("x" & i).Value, Worksheets("bulkexport").Range("af2:ag" & bulkexportrowcount), 5, False)
        
        
    Next i
    

Answer 1

A VBA Lookup (Application.Match)

• Adjust the values in the constants section.

Option Explicit

Sub VBALookup()
    
    Const s1Name As String = "kw60"
    Const s1First As String = "X2"
    Const s1ColsList As String = "Y,Z,AA,AB,AC"
    
    Const s2Name As String = "kw30"
    Const s2First As String = "X2"
    Const s2ColsList As String = "Y,Z,AA,AB,AC"
    
    Const s3Name As String = "bulkexport"
    Const s3First As String = "AC2"
    Const s3ColsList As String = "AD,AE,AF,AG"
    
    Const lName As String = "kw90"
    Const lFirst As String = "X2"
    
    Const dName As String = "kw90"
    Const dFirst As String = "Y2"
    
    Dim d1Cols As Variant: d1Cols = VBA.Array(5, 6, 7, 11, 12)
    Dim d2Cols As Variant: d2Cols = VBA.Array(8, 9, 10, 13, 14)
    Dim d3Cols As Variant: d3Cols = VBA.Array(1, 2, 3, 4)
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Lookup
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lfCell As Range: Set lfCell = lws.Range(lFirst)
    Dim llRow As Long: llRow = GetLastRow(lfCell)
    If llRow = 0 Then Exit Sub
    Dim lrg As Range
    Set lrg = lws.Range(lFirst, lws.Cells(llRow, lfCell.Column))
    Dim lData As Variant: lData = GetColumn(lrg)
    
    ' Destination (Array)
    Dim drCount As Long: drCount = UBound(lData)
    Dim dcCount As Long
    dcCount = UBound(d1Cols) + UBound(d2Cols) + UBound(d3Cols) + 3
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' Source
    SourceToArray dData, wb, s1Name, s1First, s1ColsList, drCount, lData, d1Cols
    SourceToArray dData, wb, s2Name, s2First, s2ColsList, drCount, lData, d2Cols
    SourceToArray dData, wb, s3Name, s3First, s3ColsList, drCount, lData, d3Cols
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    dfCell.Resize(drCount, dcCount).Value = dData
    
End Sub

Sub SourceToArray( _
        ByRef dData As Variant, _
        ByVal wb As Workbook, _
        ByVal sName As String, _
        ByVal sFirst As String, _
        ByVal sColsList As String, _
        ByVal drCount As Long, _
        ByVal lData As Variant, _
        ByVal dCols As Variant)

    On Error Resume Next
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    On Error GoTo 0
    If sws Is Nothing Then Exit Sub
    
    Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
    Dim slRow As Long: slRow = GetLastRow(sfCell)
    If slRow = 0 Then Exit Sub
    
    Dim srg As Range
    Set srg = sws.Range(sFirst, sws.Cells(slRow, sfCell.Column))
    Dim sCols() As String: sCols = Split(sColsList, ",")
    Dim scUpper As Long: scUpper = UBound(sCols)
    Dim sData As Variant: ReDim sData(0 To scUpper)
    
    Dim n As Long
    For n = 0 To scUpper
        sData(n) = GetColumn(srg.EntireRow.Columns(sCols(n)))
    Next n
    
    Dim rIndex As Variant
    Dim r As Long
    For r = 1 To drCount
        rIndex = Application.Match(lData(r, 1), srg, 0)
        If IsNumeric(rIndex) Then
            For n = 0 To scUpper
                dData(r, dCols(n)) = sData(n)(rIndex, 1)
            Next n
        End If
    Next r

End Sub

Function GetLastRow( _
    ByVal FirstRowRange As Range) _
As Long
    If FirstRowRange Is Nothing Then Exit Function
    Dim frrg As Range: Set frrg = FirstRowRange.Rows(1)
    Dim lCell As Range
    Set lCell = frrg.Resize(frrg.Worksheet.Rows.Count - frrg.Row + 1) _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If lCell Is Nothing Then Exit Function
    GetLastRow = lCell.Row
End Function

Function GetColumn( _
    ByVal ColumnRange As Range) _
As Variant
    If ColumnRange Is Nothing Then Exit Function
    Dim crg As Range: Set crg = ColumnRange.Columns(1)
    Dim cData As Variant
    If crg.Rows.Count = 1 Then
        ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
    Else
        cData = crg.Value
    End If
    GetColumn = cData
End Function

Answer 2

Your current approach would be a little faster if you switched to Match() to locate the correct row (which you only need to do once per row per source dataset...) - then you can pull the required cells values directly from that row.

Sub UseMatch()
   
    Dim i As Long, m, rw As Range, xVal, arr
    Dim wsKW60 As Worksheet
    
    Set wsKW60 = Worksheets("kw60")
    
    For i = 2 To kw90rowcount
        
        Set rw = Sheets("kw90").Rows(i)
        xVal = rw.Columns("X").Value
        
        'find the row once
        m = Application.Match(xVal, wsKW60.Range("x1:x" & kw60rowcount), 0)
        If Not IsError(m) Then
            arr = wsKW60.Cells(m, "Y").Resize(1, 5).Value 'got a row - read all values in one operation
            rw.Columns("AC").Value = arr(1, 1)            'then assign values from the array
            rw.Columns("AD").Value = arr(1, 2)
            rw.Columns("AE").Value = arr(1, 3)
            rw.Columns("AI").Value = arr(1, 4)
            rw.Columns("AJ").Value = arr(1, 5)
        End If
        
        'next sheets ...

    Next i
End Sub

Answer 3

I am not sure if access would be a good solution since new reports are pasted into all of these sheets daily and then the script is run - they don't hold static values.

Concerning a dictionary, I will have to look into this, as I have no experience with it. Is this the same thing as an array?

Does vlookup work faster if all sheets are first sorted alphabetically?

I also had a thought, please let me know your opinion - I wanted to try to make the vlookup range dynamic based on the previous result - if everything is alphabetical and the initial range is row 1 to 300k and the first result is on row 1000, then the next vlookup can be from rows 1001 to 300k, since I know there will be no results in rows 1-1000. Does that make sense?

Thank you

Answer 4

As mentioned, consider a database to match and lookup values between different large sets. Then, use Excel as an end-use analytical/reporting tool and not for data storage. Doing so, SQL can supplant vlookup formulas and avoid any loops. (Potentially, all three joins can be used in one query but not knowing enough of your data you may have many-to-many relationships on x column.)

SELECT kw90.*, kw60.y, kw60.z, kw60.aa, kw60.ab, kw60.ac
FROM kw90
INNER JOIN kw60 ON kw90.x = kw60.x

SELECT kw90.*, kw30.y, kw30.z, kw30.aa, kw30.ab, kw30.ac
FROM kw90
INNER JOIN kw60 ON kw90.x = kw30.x

SELECT kw90.*, kw60.y, kw60.z, kw60.as, kw60.ab, kw60.ac
FROM kw90
INNER JOIN bulkexport ON kw90.x = bulkexport.x

Actually, too, you can run SQL on workbooks if using Excel for PC. Excel can connect to the Jet/ACE SQL Engine (Window .dll files) to run queries on worksheets as if they were database tables.

As example, below query runs an INNER JOIN between two sheets, kw90 and kw60 with output to existing worksheet, Results. (Named columns should be used in SQL instead of lettered positions.)

Sub RunSQL()    
    Dim conn As Object, rst As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer
    
    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    
    ' CONNECTION STRINGS (DRIVER VERSION COMMENTED OUT)
'    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
'                      & "DBQ=C:\Path\To\Workbook.xlsm;"
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                       & "Data Source='C:\Path\To\Workbook.xlsm';" _
                       & "Extended Properties=""Excel 12.0;HDR=YES;"";"
    
    strSQL = "SELECT kw90.*, " _
             & "     kw60.y, kw60.z, kw60.as, kw60.ab, kw60.ac "_
             & "FROM [kw90$] AS kw90" _
             & "INNER JOIN [kw60$] AS kw60 ON kw90.x = kw60.x" 
      
    ' OPEN CONNECTION
    conn.Open strConnection
    rst.Open strSQL, conn
    
    ' COLUMN HEADERS
    For i = 1 To rst.Fields.Count - 1
        Worksheets("Results").Cells(1, i) = rst.Fields(i).Name
    Next i        
    ' DATA ROWS
    Worksheets("Results").Range("A2").CopyFromRecordset rst
        
    rst.Close: conn.Close   
    Set rst = Nothing: Set conn = Nothing 
End Sub