Multiple Vlookup values between worksheet VBA

[Lunatik]

I am building a Lookup value between two worksheets in the same workbook. I can get this code to work with smaller data that are only number driven but when I add the letter or other values it does give me some problems in #1 line "Private Sub" .

Should I write the code as an iRow to speed up the process and avoid any issues with debugging? Any help appreciated.


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
OptimizeVBA True
Dim startTime As Single, endTime As Single
startTime = Timer

Dim bol As Range, source As Range, cust As Range, prodname As Range, trailer As Range, accnt As Range, brix As Range, ph As Range
Dim lookupBOL As Range, lookupSource As Range, lookupCust As Range, LookupProdname As Range, lookupTrailer As Range, lookupAccnt As Range, lookupBrix As Range, lookupPh As Range
Dim vlookupCol As Object

Set bol = Worksheets("Data").Range("B:B")
Set soruce = Worksheets("Data").Range("D:D")
Set cust = Worksheets("Data").Range("E:E")
Set prodname = Worksheets("Data").Range("H:H")
Set trailer = Worksheets("Data").Range("J:J")
Set accnt = Worksheets("Data").Range("L:L")
Set brix = Worksheets("Data").Range("T:T")
Set ph = Worksheets("Data").Range("V:V")
Set lookupBOL = Worksheets("Deliveries").Range("B:B")
Set lookupSouce = Worksheets("Deliveries").Range("K:K")
Set lookupCust = Worksheets("Deliveries").Range("J:J")
Set LookupProdname = Worksheets("Deliveries").Range("L:L")
Set lookupTrailer = Worksheets("Deliveries").Range("H:H")
Set lookupAccnt = Worksheets("Deliveries").Range("I:I")
Set lookupBrix = Worksheets("Deliveries").Range("F:F")
Set lookupPh = Worksheets("Deliveries").Range("G:G")

'Build Collection
Set vlookupCol = BuildLookupCollection(bol, source, cust, prodname, trailer, accnt, brix, ph)

'Lookup the values
VLookupValues lookupBOL, lookupSource, lookupCust, LookupProdname, lookupTrailer, lookupAccnt, lookupBrix, lookupPh, vlookupCol
endTime = Timer
Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
OptimizeVBA 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
Call vlookupCol.Add(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

 

[svendiamond]

Use the code tags when you post code on the forum. Like this (but without the spaces):

[code ]
'your code here
[/ code]

That way it will look like this

'your code here

Also unrelated to your question but just a tip for writing code, use "With" so you don't have to keep typing the sheet name, for example:

With Worksheets("Data")
     Set bol = .Range("B:B")
     Set soruce = .Range("D:D")
     Set cust = .Range("E:E")
End With

 

[svendiamond]

But also I have a question. What is the overall purpose of this code? Why don't you just use a VLOOKUP formula? Are you running multiple VLOOKUPs at the same time, and so often that you need to automate it? Just wondering for clarity's sake.

 

[Lunatik]

Hi svendiamond
Thanks for the tip. Here is the code.
I am running multiple Lookup in this spreadsheet, and its makes it easy for me to fix when a data is modified when I run a code other than a formula. Thanks for the tip using the "with" I still learning how to code better, but I am always looking at other people work and modifying it and as well adding from what I learn and what i see. I will make the change using the with.



I really appreciate the help,

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
OptimizeVBA True
Dim startTime As Single, endTime As Single
startTime = Timer

Dim bol As Range, source As Range, cust As Range, prodname As Range, trailer As Range, accnt As Range, brix As Range, ph As Range
Dim lookupBOL As Range, lookupSource As Range, lookupCust As Range, LookupProdname As Range, lookupTrailer As Range, lookupAccnt As Range, lookupBrix As Range, lookupPh As Range
Dim vlookupCol As Object

Set bol = Worksheets("Data").Range("B:B")
Set soruce = Worksheets("Data").Range("D:D")
Set cust = Worksheets("Data").Range("E:E")
Set prodname = Worksheets("Data").Range("H:H")
Set trailer = Worksheets("Data").Range("J:J")
Set accnt = Worksheets("Data").Range("L:L")
Set brix = Worksheets("Data").Range("T:T")
Set ph = Worksheets("Data").Range("V:V")
Set lookupBOL = Worksheets("Deliveries").Range("B:B")
Set lookupSouce = Worksheets("Deliveries").Range("K:K")
Set lookupCust = Worksheets("Deliveries").Range("J:J")
Set LookupProdname = Worksheets("Deliveries").Range("L:L")
Set lookupTrailer = Worksheets("Deliveries").Range("H:H")
Set lookupAccnt = Worksheets("Deliveries").Range("I:I")
Set lookupBrix = Worksheets("Deliveries").Range("F:F")
Set lookupPh = Worksheets("Deliveries").Range("G:G")

'Build Collection
Set vlookupCol = BuildLookupCollection(bol, source, cust, prodname, trailer, accnt, brix, ph)

'Lookup the values
VLookupValues lookupBOL, lookupSource, lookupCust, LookupProdname, lookupTrailer, lookupAccnt, lookupBrix, lookupPh, vlookupCol
endTime = Timer
Debug.Print (endTime - startTime) & " seconds have passed [<acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-top-style: initial; border-right-style: initial; border-bottom-style: dotted; border-left-style: initial; border-top-color: initial; border-right-color: initial; border-bottom-color: rgb(0, 0, 0); border-left-color: initial; border-image: initial; cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym>]"
OptimizeVBA 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
Call vlookupCol.Add(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