VBA code to vlookup between workbooks

[Dokat]

The vlookup range is still the same "Set srng = sw.Sheets(1).Range("D:R")" no changes there and it looks accurate. Thanks

 

[Nebu]

Hi:

Yes, the file is running without any issue at my end.

Thanks

 

[Dokat]

I saved the file you sent and rerun it but still no luck...not sure whats causing it. Thanks

 

[Dokat]

not sure but still getting 1004 error message below.

 

[Nebu]

Hi:

Did you try manually constructing the vlookup formula and see whether it is giving you the right results.

Thanks

 

[Dokat]

hi,

yes I manually run the vlookup and getting the right results. There is no change to vlookup value or lookup range.

thanks

 

[Dokat]

also the original code you sent works i just cant figure out why i cant get the updated code to work. Thanks

 

[Nebu]

Ok

Try this code.

Sub test()
Application.ScreenUpdating = False

Dim sw As Workbook
Dim dw As Workbook
Dim srng As Range

swname$ = "Segmentation.xlsx"
swpath$ = ThisWorkbook.Path & "\" & swname
Set dw = ThisWorkbook
c& = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Workbooks.Open (swpath)
Set sw = Workbooks(swname)
Set srng = sw.Sheets(1).Range("D:R")

    On Error Resume Next
    Sheet1.Range("Q2:Q" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 5, False)"
    On Error Resume Next
    Sheet1.Range("R2:R" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 8, False)"
    On Error Resume Next
    Sheet1.Range("S2:S" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 9, False)"
    On Error Resume Next
    Sheet1.Range("T2:T" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 10, False)"
    On Error Resume Next
    Sheet1.Range("U2:U" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 11, False)"
    On Error Resume Next
    Sheet1.Range("V2:V" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 13, False)"
    On Error Resume Next
    Sheet1.Range("W2:W" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 14, False)"
    On Error Resume Next
    Sheet1.Range("X2:X" & c).Formula = "=VLookup(D2,[Segmentation.xlsx]Sheet1!" & srng.Address & ", 15, False)"
   
    Sheet1.Range("Q2:X" & c).Copy
    Sheet1.Range("Q2").PasteSpecial xlValues
    Application.CutCopyMode = False
sw.Close

Application.ScreenUpdating = True
End Sub

Thanks

 

[Dokat]

I get no error....but code doesnt return any value...its just blank. Thank you

 

[Nebu]

Hi:

Unless you share your original file. I won't be able to help you because I cannot replicate you error at my end.

Thanks

 

[Dokat]

Attached is the file. I really appreciate your help

 

[Nebu]

Hi:

The code is working just fine at my end. I am not sure what is happening at your end. Hope you have saved both the file in the same folder.

Thanks

 

[Dokat]

yes both segmentation and final files are saved under same folder. I restarted my computer incase there is an issue with cache but still no luck

 

[Dokat]

When i ran the code it only highlights the area it suppose to return to vlookupvalues. thank you

 

[Chihiro]

Just a thought. Using MS Query, you can use unequal self-join to only return single row for each Primary SKU. You can then join that with your Final table.

Replace "FilePath" to actual file location.
SQL Command Text:

Select *
From(
SELECT  t1.`Primary SKU`, t1.Category, t1.Placement, t1.Segment, t1.Form,
t1.Size, t1.`Liquid Laundry Size`, t1.Manufacturer, t1.Brand,
COUNT(*) As [Ino Seq]
FROM `C:\FilePath\Segmentation.xlsx`.`Sheet1$` As t1
INNER JOIN
`C:\FilePath\Segmentation.xlsx`.`Sheet1$` As t2
    ON t2.`Primary SKU` = t1.`Primary SKU`
    AND t2.INO <= t1.INO
Group by t1.`Primary SKU`, t1.Category, t1.Placement, t1.Segment, t1.Form,
t1.Size, t1.`Liquid Laundry Size`, t1.Manufacturer, t1.Brand
Order by 2, 10
) as t
Where [Ino Seq] = 1

NOTE: I added INO column to your Segmentation.xlsx file. Sequential number from 1~.

I'll take a look at VBA code later.

Edit: It is unfortunate that MS Query does not support row_number() function... hence need to add INO column before query.

 

[Chihiro]

Here's VBA code for VLOOKUP using dictionary and array.

Sub TestVBA()
    OptimizeVBA True
    Dim startTime As Single, endTime As Single
    startTime = Timer
  
    Dim sWb As Workbook
    Dim fWs As Worksheet, sWs As Worksheet
    Dim slRow As Long, flRow As Long
    Dim pSKU As Range, luVal As Range
    Dim lupSKU As Range, outputCol As Range
    Dim vlookupCol As Object
  
    Set sWb = Workbooks.Open(ThisWorkbook.Path & "\Segmentation.xlsx")
    Set sWs = sWb.Sheets("Sheet1")
    Set fWs = ThisWorkbook.Sheets("Sheet1")
  
    slRow = sWs.Cells(Rows.Count, 4).End(xlUp).Row
    flRow = fWs.Cells(Rows.Count, 4).End(xlUp).Row
  
    Set pSKU = sWs.Range("D2:D" & slRow)
    Set lupSKU = fWs.Range("D2:D" & flRow)
  
    For i = 17 To 24
        Set outputCol = fWs.Range(fWs.Cells(2, i), fWs.Cells(flRow, i))
        Select Case i
            Case 17
                Set luVal = sWs.Range("H2:H" & slRow)
            Case 18
                Set luVal = sWs.Range("K2:K" & slRow)
            Case 19
                Set luVal = sWs.Range("L2:L" & slRow)
            Case 20
                Set luVal = sWs.Range("M2:M" & slRow)
            Case 21
                Set luVal = sWs.Range("N2:N" & slRow)
            Case 22
                Set luVal = sWs.Range("P2:P" & slRow)
            Case 23
                Set luVal = sWs.Range("Q2:Q" & slRow)
            Case 24
                Set luVal = sWs.Range("R2:R" & slRow)
        End Select
  
    'Build Collection
        Set vlookupCol = BuildLookupCollection(pSKU, luVal)
  
    'Lookup the values
        VLookupValues lupSKU, outputCol, vlookupCol
    Next i
  
    endTime = Timer
    Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
    OptimizeVBA False
    sWb.Close False
    Set vlookupCol = Nothing
End Sub
Function BuildLookupCollection(categories As Range, values As Range)
    Dim vlookupCol As Object, i As Long
    Set vlookupCol = CreateObject("Scripting.Dictionary")
    For i = 1 To categories.Rows.Count
        vlookupCol.Item(CStr(categories(i))) = values(i)
    Next i
  
    Set BuildLookupCollection = vlookupCol
End Function
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, vlookupCol As Object)
    Dim i As Long, resArr() As Variant
    ReDim resArr(lookupCategory.Rows.Count, 1)
    For i = 1 To lookupCategory.Rows.Count
        resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
    Next i
    lookupValues = resArr
End Sub
Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub

This is based on code found in link (look in how does VBA lookup procedure work)
http://analystcave.com/excel-vlookup-vs-index-match-vs-sql-performance/

When tested on my machine. Took less than 1 sec to return result.

Note: Both files need to be in same folder.

 

[Dokat]

I made it work just had to rename the sheet. I am going to test it in the original worksheet with 280K rows and see if it will run it faster than vlookups. Thank you so much for your help!

 

[Dokat]

Hi Chiriro,

This is absolutely amazing!!!!!!It takes less than a second or two to run the entire code in 280K rows. Crazy fast...normally it takes me 30 mins to run the code. I can not thank you and Nebu enough for this.

 

[Dokat]

Last question is there a way to not have to save segmentation and final workbook on same path. Is there a way to save it under different folders?

Thanks

 

[Chihiro]

Yes. Just hard code path for Segmentation file. Instead of using ThisWorkbook.Path & "\Segmentation.xlsx".

 

[Dokat]

Perfect! Thank you so much

 

[mdc23]

Well done Guys. Very Helpful.

Chihiro - What if my destination columns are NOT in a continuous range and I have blank columns in between? For example, say I don't want to lookup into columns 18 and 23. So I excluded them from the code. It now will paste output for column 17 into 17 and 18, and output for column 22 into 22 and 23. However, I would like to leave columns 18 and 23 blank. Thanks!

For i = 17 To 24
        Set outputCol = fWs.Range(fWs.Cells(2, i), fWs.Cells(flRow, i))
        Select Case i
            Case 17
                Set luVal = sWs.Range("H2:H" & slRow)
            Case 19
                Set luVal = sWs.Range("L2:L" & slRow)
            Case 20
                Set luVal = sWs.Range("M2:M" & slRow)
            Case 21
                Set luVal = sWs.Range("N2:N" & slRow)
            Case 22
                Set luVal = sWs.Range("P2:P" & slRow)
            Case 24
                Set luVal = sWs.Range("R2:R" & slRow)
        End Select

 

[Chihiro]

Without looking at your source range and expected output, can't really help you.
Likely you should use Array() and loop through array element, rather than incremental loop.

 

[mdc23]

Thanks for reply! I figured it out. Went with below. Skips columns 18 and 23 in the destination sheet.

 Set pSKU = sWs.Range("A2:A" & slRow)
    Set lupSKU = fWs.Range("A6:A" & flRow)
 
    For i = 17 To 24
    skipIt = False
    skipIt = skipIt Or (i = 18)
    skipIt = skipIt Or (i = 23)
    If Not skipIt Then
        Set outputCol = fWs.Range(fWs.Cells(2, i),fWs.Cells(flRow, i))
        Select Case i
            Case 17
                Set luVal = sWs.Range("H2:H" & slRow)
            Case 19
                Set luVal = sWs.Range("L2:L" & slRow)
            Case 20
                Set luVal = sWs.Range("M2:M" & slRow)
            Case 21
                Set luVal = sWs.Range("N2:N" & slRow)
            Case 22
                Set luVal = sWs.Range("P2:P" & slRow)
            Case 24
                Set luVal = sWs.Range("R2:R" & slRow)
        End Select
    End If

 

[mdc23]

Here is the complete final code I used. Truly powerful vba to vlookup lots of data from another workbook based on unique values. Thanks!

Sub Lookup()
    OptimizeVBA True
    Dim startTime As Single, endTime As Single
    startTime = Timer
 
    Dim sWb As Workbook
    Dim fWs As Worksheet, sWs As Worksheet
    Dim slRow As Long, flRow As Long
    Dim pSKU As Range, luVal As Range
    Dim lupSKU As Range, outputCol As Range
    Dim vlookupCol As Object
    Dim i As Integer
 
    Set sWb = Workbooks.Open("C:\Users\america.xlsx")
    Set sWs = sWb.Sheets("source data")
    Set fWs = ThisWorkbook.Sheets("Destination")
 
    slRow = sWs.Cells(Rows.Count, 1).End(xlUp).Row
    flRow = fWs.Cells(Rows.Count, 1).End(xlUp).Row
 
    Set pSKU = sWs.Range("A2:A" & slRow)
    Set lupSKU = fWs.Range("A6:A" & flRow)
 
    For i = 17 To 24
    skipIt = False
    skipIt = skipIt Or (i = 18)
    skipIt = skipIt Or (i = 23)
    If Not skipIt Then
        Set outputCol = fWs.Range(fWs.Cells(6, i),fWs.Cells(flRow, i))
        Select Case i
            Case 17
                Set luVal = sWs.Range("H2:H" & slRow)
            Case 19
                Set luVal = sWs.Range("L2:L" & slRow)
            Case 20
                Set luVal = sWs.Range("M2:M" & slRow)
            Case 21
                Set luVal = sWs.Range("N2:N" & slRow)
            Case 22
                Set luVal = sWs.Range("P2:P" & slRow)
            Case 24
                Set luVal = sWs.Range("R2:R" & slRow)
        End Select
    End If
 
    'Build Collection
        Set vlookupCol = BuildLookupCollection(pSKU, luVal)
 
    'Lookup the values
        VLookupValues lupSKU, outputCol, vlookupCol
    Next i
 
    endTime = Timer
    Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
    OptimizeVBA False
    sWb.Close False
    Set vlookupCol = Nothing
End Sub
Function BuildLookupCollection(categories As Range, values As Range)
    Dim vlookupCol As Object, i As Long
    Set vlookupCol = CreateObject("Scripting.Dictionary")
    For i = 1 To categories.Rows.Count
        vlookupCol.Item(CStr(categories(i))) = values(i)
    Next i
 
    Set BuildLookupCollection = vlookupCol
End Function
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, vlookupCol As Object)
    Dim i As Long, resArr() As Variant
    ReDim resArr(lookupCategory.Rows.Count, 1)
    For i = 1 To lookupCategory.Rows.Count
        resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
    Next i
    lookupValues = resArr
End Sub
Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub