I need tips on improving my Multi Vlookup code

abdul hafeel

New Member
Joined
Oct 14, 2006
Messages
9
Hi,

I have an VBA module to perform Multi Column Vlookups. I am posting it here so that It can be improved. Current deficiencies

(1) Manually adjust code for performing more than 2 column lookups
(2) Crashes when the Lookup range has Null set

Advantages are
(1) its free!
(2) Unlike conventional Vlookup you can perform the Vlookup operation on the entire criteria lookup range. No need to select a single cell & then drag it down.

Pls help me improve my coding. I hope you find this useful.
My contact Email : EDIT: E-Mail address removed by moderator, code tags added & Welcome to the Board while we're at it!

Thanks in advance Fellow Coders :cool:


Here's the code

Code:
Sub SelectRange()
'****************************************************
'This section is for the Data Range criteria
Dim r, c As Integer
Dim m, N As Integer
Dim data As range

'*******************************************************************
Prompt = "Select a Valid Data Range for Lookup."
Title = "Select a valid Data Range"
'   Display the Input Box
    On Error Resume Next
    Set data = Application.InputBox( _
        Prompt:=Prompt, _
        Title:=Title, _
        Default:=ActiveCell.Address, _
        Type:=8) 'Range selection

'   Was the Input Box canceled?
    If data Is Nothing Then
        MsgBox "Canceled."
    Else
        
    End If
'*******************************************************************

'Application.Selection.Activate
data.Select
r = Selection.Rows.Count
c = Selection.Columns.Count
Dim RangeArray() As Variant
ReDim Preserve RangeArray(r, c)
N = o
Do Until N = c
m = 0
Do Until m = r
RangeArray(m, N) = ActiveCell.Offset(m, N).Value
'MsgBox RangeArray(m, n)
m = m + 1
Loop
N = N + 1

Loop
'*****************************************************
'Now This section is for the Lookup criteria
Dim x, y As Integer
Dim find As range
Dim Index As Variant
'*******************************************************************
'*******************************************************************
Prompt = "Select a Cell/Range for the output."
Title = "Select a Cell/Range"
'   Display the Input Box
    On Error Resume Next
    Set find = Application.InputBox( _
        Prompt:=Prompt, _
        Title:=Title, _
        Default:=ActiveCell.Address, _
        Type:=8) 'Range selection

'   Was the Input Box canceled?
    If find Is Nothing Then
        MsgBox "Canceled."
    Else
        
    End If
'*******************************************************************

On Error Resume Next
MsgBox range(find).Address
'range(find).Select
find.Select
x = Selection.Rows.Count
y = Selection.Columns.Count
ReDim Index(x, y)

N = o
Do Until N = y
m = 0
Do Until m = x
Index(m, N) = ActiveCell.Offset(m, N).Value
m = m + 1
Loop
N = N + 1
Loop

Call SearchArray(RangeArray, Index, 3)
End Sub

Code:
Function SearchArray(Array2 As Variant, criteria As Variant, N As Integer)
Dim a, b, c As Integer
b = 0
Do Until b = UBound(criteria)
a = 0
Do Until a = UBound(Array2)
'Code that actually does the VLookup Job!
'*********************************************
If criteria(b, 0) = Array2(a, 0) Then       '*
If criteria(b, 1) = Array2(a, 1) Then       '*
'MsgBox Array2(a, 2)                        '*
'MsgBox ActiveCell.Offset(b, 2).Value       '*                                            '*
If ActiveCell.Offset(b, 2).Value = "" Then  '*
ActiveCell.Offset(b, 2) = Array2(a, 2)      '*
End If                                      '*
End If                                      '*
End If                                      '*
'*********************************************
a = a + 1
Loop
b = b + 1
Loop

End Function
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

Forum statistics

Threads
1,136,579
Messages
5,676,652
Members
419,638
Latest member
GlenMc52

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
Top