Mapping table with multiple items - vba

Question

I have a mapping table which I use for matching headers of two separate sheets (Sheet1 and Sheet2).
But what if I have something like this (3 columns in the left part, 2 columns in the right):
Basically I want POS1 2019 EMP1 to be equal to HR DEPARTMAENT Employee1 and so on.
Sheet1,
Sheet2,
Mapping
Any ideas how can I do it?
Thank you in advance! :)
Public Sub test()
Application.ScreenUpdating = False
stack "Sheet1", "Sheet2", "Mapping"
Application.ScreenUpdating = True
End Sub
Public Sub stack(ByVal Sheet1 As String, ByVal Sheet2 As String, ByVal
Mapping As String)
Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As
Worksheet, helper As Worksheet
Dim rngSrc As Range, rngDest As Range
Dim sht As Worksheet
Set src = Worksheets("Sheet1")
Set trgt = Worksheets("Sheet2")
Set helper = Worksheets("Mapping")
With src
For Each rng In Intersect(.Rows(3), .UsedRange).SpecialCells(xlCellTypeConstants)
Dim lkup As Variant
With helper
lkup = Application.VLookup(rng.Value, .Range("D13:E" & .Cells(.Rows.Count, "D").End(xlUp).Row), 2, False)
End With
If Not IsError(lkup) Then
Set trgtCell = trgt.Range("$B$2:$F$7").Find(lkup, LookIn:=xlValues, lookat:=xlWhole)
If Not trgtCell Is Nothing Then
.Range(rng.Offset(1), .Cells(.Rows.Count, rng.Column).End(xlUp)).Copy
With trgt
.Range(Split(trgtCell.Address, "$")(1) & 3).PasteSpecial
End With
End If
End If
Next rng
End With
End Sub

Answer 1

I think dictionaries are the data structure most suited to this type of problem.
Be aware, to use dictionaries in VBA you need to set a reference to the Scripting Runtime library.
Tools->Reference-> Microsoft Scripting Runtime
Here is some code that works on the example you provided:
Public Sub test()
Application.ScreenUpdating = False
stack2 "Sheet1", "Sheet2", "Mapping"
Application.ScreenUpdating = True
End Sub
Public Sub stack(ByVal Sheet1 As String, ByVal Sheet2 As String, ByVal Mapping As String)
Dim rng As Range, src As Worksheet, trgt As Worksheet, helper As Worksheet
Dim sht As Worksheet
Dim dctCol As Dictionary, dctHeader As Dictionary
Dim strKey1 As String, strKey2 As String
Dim strItem As String, col As Integer
Set src = Worksheets(Sheet1)
Set trgt = Worksheets(Sheet2)
Set helper = Worksheets(Mapping)
'build a dictionary to lookup column based on 3 rows of headers
Set dctCol = New Dictionary
arr1 = src.Range("A1:F7") 'arrays are way faster than ranges
For j = 2 To UBound(arr1, 2) 'loop over data from columns B-F
strKey1 = Trim(arr1(1, j)) & "," & Trim(arr1(2, j)) & "," & Trim(arr1(3, j)) 'comma delimit string
dctCol(strKey1) = j 'j is the column number
Next
'build a dictionary to translate 2 headers to 3 headers
Set dctHeader = New Dictionary
arrHelp = helper.Range("A2:E6")
For i = 1 To UBound(arrHelp)
strKey2 = Trim(arrHelp(i, 4)) & "," & Trim(arrHelp(i, 5)) '2 header key
strItem = Trim(arrHelp(i, 1)) & "," & Trim(arrHelp(i, 2)) & "," & Trim(arrHelp(i, 3))
dctHeader(strKey2) = strItem
Next
'update sheet2 with numbers from sheet1
arr2 = trgt.Range("A1:F6")
For j = 2 To 5
'work backwards to find the column
strKey2 = Trim(arr2(1, 2)) & "," & Trim(arr2(2, j)) '2 headers
strKey1 = dctHeader(strKey2)
col = dctCol(strKey1)
'update the data for arr2
For i = 3 To 6
arr2(i, j) = arr1(i + 1, col)
Next
Next
'write it back to spreadsheet
trgt.Range("M10").Resize(UBound(arr2), UBound(arr2, 2)) = arr2
End Sub

Answer 2

Please, try the next adapted code.
Public Sub test()
Application.ScreenUpdating = False
stack "Sheet1", "Sheet2", "Mapping"
Application.ScreenUpdating = True
End Sub
Public Sub stack(ByVal Sheet1 As String, ByVal Sheet2 As String, ByVal Mapping As String)
Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As Worksheet, helper As Worksheet
Dim rngSrc As Range, rngDest As Range
Dim sht As Worksheet
Set src = Worksheets(Sheet1)
Set trgt = Worksheets(Sheet2)
Set helper = Worksheets(Mapping)
With src
For Each rng In Intersect(.Rows(3), .UsedRange).SpecialCells(xlCellTypeConstants)
Dim lkup As Variant
With helper
lkup = Application.VLookup(rng.Value, .Range("C2:E" & .Cells(.Rows.Count, "C").End(xlUp).Row), 3, False)
End With
If Not IsError(lkup) Then
Set trgtCell = trgt.Range("$B$2:$F$7").Find(lkup, LookIn:=xlValues, lookat:=xlWhole)
Debug.Print trgtCell.Address
If Not trgtCell Is Nothing Then
With trgt
.Range(trgtCell.Offset(1), .Cells(.Rows.Count, trgtCell.Column).End(xlUp)).Copy
End With
.Range(Split(trgtCell.Address, "$")(1) & 4).PasteSpecial
End If
End If
Next rng
End With
End Sub
Please, also correct the sub calling the second one. You mixed "Shee2" with "Sheet1" there...
Please, test it and send some feedback.