Lookup using Index match based on column name where search Column is not the first

[Jonnathanjons]

Below VBA script I have currently pull the results only if the search value column is in the first column. Example Emp ID to search should be in Column A.I would like the script to fetch the results for multiple columns based on header name irrespective of the position of the search header column. Please you may change the script to fit to run quicker as I have over 50 K search line from sheet2.This script works in the attached file if the first 3 columns are removed.
Sheet 1 is Search tab and Sheet 2 is the Raw "Data" which is the source. attached a working file

Sub IndexMatcharray()

Application.ScreenUpdating = False
Dim x As Integer, y As Integer
Dim ws As Worksheet
Dim strFile As String
Dim TableArray As Range, hRange As Range

Const m = "MESSAGE", S = "Data"
If Not Evaluate("ISREF('" & S & "'!A1)") Then
Sheets.Add(, ActiveSheet).Name = S
Application.StatusBar = "Add your search list in Sheet 'DATA' column A and Proceed!!": Exit Sub
Application.StatusBar = False
Else
Application.StatusBar = False
End If
Set wsED = ActiveWorkbook.ActiveSheet
Set hRange = wsED.Range("1:1")
Set rED = ActiveWorkbook.Sheets(S)
Set xRange = rED.Range("A:A")
Set hdxRange = rED.Range("1:1")
Set TableArray = rED.UsedRange.Columns

empid = WorksheetFunction.Match("EMP ID", hRange, 0)
ColPI = WorksheetFunction.Match("Port ID", hRange, 0)
ColDes = WorksheetFunction.Match("Designation", hRange, 0)
ColN = WorksheetFunction.Match("Name", hRange, 0)
ColLoc = WorksheetFunction.Match("Location", hRange, 0)

LastRow = wsED.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = wsED.Cells(1, Columns.Count).End(xlToLeft).Column

For x = 2 To LastRow
For y = 2 To LastCol

On Error Resume Next
wsED.Cells(x, y) = WorksheetFunction.Index(TableArray, _
WorksheetFunction.Match(wsED.Cells(x, empid), xRange, 0), _
WorksheetFunction.Match(wsED.Cells(empid, y), hdxRange, 0))

Next y
Next x
Application.ScreenUpdating = True
End Sub

 

[p45cal]

try instead:

Sub Lookupbyheader()
Application.ScreenUpdating = False
Dim x As Long, y As Long, empid As Long, LastRow As Long, LastCol As Long, SourceRow As Long, SourceColmNo As Long
Dim ws As Worksheet, wsed As Worksheet, red As Worksheet
Dim strFile As String
Dim TableArray As Range, hRange As Range, xrange As Range, hdxRange As Range

Const m = "MESSAGE", S = "Data"

If Not Evaluate("ISREF('" & S & "'!A1)") Then
  Sheets.Add(, ActiveSheet).Name = S
  Application.StatusBar = "Add your search list in Sheet 'DATA' column A and proceed!!": Exit Sub
End If
Application.StatusBar = False
Set wsed = ActiveWorkbook.ActiveSheet            'vbaoutput
Set hRange = wsed.Range("1:1")                   'destn headers

Set red = ActiveWorkbook.Sheets(S)               'Data
Set xrange = red.Range("A:A")
Set hdxRange = red.Range("1:1")
empid = WorksheetFunction.Match("EMP ID", hRange, 0) 'the column on the destn sheet where the IDs are.

Set TableArray = red.UsedRange.Columns

LastRow = wsed.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = wsed.Cells(1, Columns.Count).End(xlToLeft).Column
On Error Resume Next
For x = 2 To LastRow
  SourceRow = WorksheetFunction.Match(wsed.Cells(x, empid), xrange, 0)
  For y = 5 To LastCol
    SourceColmNo = WorksheetFunction.Match(hRange.Cells(y), hdxRange, 0)
    wsed.Cells(x, y) = WorksheetFunction.Index(TableArray, SourceRow, SourceColmNo)
  Next y
Next x
Application.ScreenUpdating = True
End Sub

 

[Jonnathanjons]

Hello p45cal, This works partially as it lookup even though the key column for the search is not in the first column . thanks for the time spend on this.. However There is an issue in this. My actual search sheet ( ie ActiveSheet) has columns names in between which are not matching with the source data and should be ignored while lookup. Any columns not matching should be left blank and should populate only for matching columns with Sheet"Data" Hence I had "On Error Resume Next" line in my script to ignore any non matching column names . When I ran above script it populates for every matching and also non matching columns in between . Non matching column is getting populated with previous matching column data and is not correct. Data should be populated only for the matching columns. Hope I am making sense Also I have a second request ...please help me with this line "For y = 5 To LastCol " in your script .please help to fetch the column number based on the header name. So I dont have to change it everytime the header column is changed for another person who run this. It can be in column 7 or 40 depends on how he pull the search data to populate the raw data from sheet"Data"..I have tried several ways to convert column name to number but not showing the right result. Thanks again for the great work.
I have attached a revised xlsm sheet and my sincere apologies for not bringing this previously.

I tried below for For y = 5 To LastCol
col = Application.WorksheetFunction.Match("Emp id", _
ActiveSheet.Rows(1), 0)
For y = col To LastCol

but not getting desired result.

 

[p45cal]

Try:

Sub Lookupbyname()
Const m = "MESSAGE", S = "Data"
Application.ScreenUpdating = False
On Error GoTo exitnicely
If Not Evaluate("ISREF('" & S & "'!A1)") Then
  Sheets.Add(, ActiveSheet).Name = S
  Application.StatusBar = "Add your search list in Sheet 'DATA' column A and proceed!!": Exit Sub
End If
Application.StatusBar = False

Set WsDestn = ActiveWorkbook.ActiveSheet         'vbaoutput
Set DestnHdrs = WsDestn.Range("1:1")             'destn headers

Set WsSource = ActiveWorkbook.Sheets(S)          'Data
Set SourceIDs = WsSource.Range("A:A")
Set SourceHdrs = WsSource.Range("1:1")
DestnEmpIDColm = WorksheetFunction.Match("EMP ID", DestnHdrs, 0) 'the column on the destn sheet where the IDs are.

DestnLastRow = WsDestn.Cells(Rows.Count, 1).End(xlUp).Row
DestnLastCol = WsDestn.Cells(1, Columns.Count).End(xlToLeft).Column

'Map Destn headers to Source headers:
ReDim DestnHdrColms(1 To DestnLastCol)
ReDim SourceHdrColms(1 To DestnLastCol)
Count = 0
For Each cll In DestnHdrs.Resize(, DestnLastCol)
  xx = Application.Match(cll.Value, SourceHdrs, 0)
  If Not IsError(xx) Then
    Count = Count + 1
    DestnHdrColms(Count) = cll.Column
    SourceHdrColms(Count) = xx
  End If
Next cll
'Copy Data:
For rw = 2 To DestnLastRow
  SourceRow = Application.Match(WsDestn.Cells(rw, DestnEmpIDColm), SourceIDs, 0) 
  If Not IsError(SourceRow) Then
    For i = 1 To Count
      WsDestn.Cells(rw, DestnHdrColms(i)).Value = WsSource.Cells(SourceRow, SourceHdrColms(i)).Value
    Next i
  End If
Next rw
exitnicely:
Application.ScreenUpdating = True
End Sub

 

[Jonnathanjons]

Hello p45cal. I can't THANK YOU enough for this great script. This works wonderfully This indeed save me alot of time in lookup 15 to 20 columns from the source sheet based on Emp id. I hope this lookup works for all types like Characters, Integers, or mixed type of Emp id .Thanks a lot

 

[Jonnathanjons]

Dear p45cal, I was presenting this script to my team and was appreciated by the team mates having this script created to populate the Index match lookup automatically based on sheet "Data" Thanks again for your script.
There is a request suggested by 1 of my team if its possible for the lookup script to consolidate data from multiple source sheets. So In the script I have added Const m = "MESSAGE", S = "Data", R = "Travel" to pull the data from sheet Travel to the VBA Output search sheet Columns "Travel Exp" and "Non Travel Exp". Please refer column Q and R in the main sheet which should also look up from the sheet Travel. Do I need to raise this query as a separate question or okay to be part of the old query raised. I can raise a new question if its required. I am attaching the new xlsm sheet added the new requirement. Do let me know if you have any question. pls refer the new attachment.

 

[p45cal]

In the attached, run the macro blah.
ps. there is no sheet Travel