CODEWITHSUNDEEP
excelvbamappingmatchrowheader
TedroyG
TedroyG

Reputation: 49

Matching row headers

I have a mapping table which I use for matching column headers of two separate sheets (Sheet1 and Sheet2). But when I also want to match the row headers (months) the code is matching the rows, not the cells on column A. Any ideas how can I make this work? Thank you in advance! :)

Sheet1- src:

Sheet1-src

Sheet2- trgt (After I run the code, it should also match Oct, Nov, Dec):

Sheet2-trgt,

Mapping table:

Mapping

Sheet2- What I need:

Sheet2- what I really need

Public Sub ceva()
  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, 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
Dim LastRow As Long, LastCol As Long

Set src = Worksheets(Sheet1)
Set trgt = Worksheets(Sheet2)
Set helper = Worksheets(Mapping)          

LastRow = trgt.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = trgt.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Set dctCol = New Dictionary
arr1 = src.Range("A1:F9")
''arr1 = src.Range("A4").End(xlDown).End(xlToRight)
For j = 2 To UBound(arr1, 2)
    strKey1 = Trim(arr1(1, j)) & "," & Trim(arr1(2, j)) & "," & Trim(arr1(3, j)) 
    dctCol(strKey1) = j 
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:F12")
For j = 2 To 6
    'work backwards to find the column
    strKey2 = Trim(arr2(1, 2)) & "," & Trim(arr2(2, j)) '2 headers
    strKey1 = dctHeader(strKey2)
    col = dctCol(strKey1)
    
    For i = 3 To 12
      If src.Cells(i + 1, "A").Value = trgt.Cells(i, "A").Value Then
        arr2(i, j) = arr1(i + 1, col)
      Else
    
      End If
    Next       
Next

trgt.Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2
End Sub

Upvotes: 0

Views: 98

Answers (1)

CDP1802
CDP1802

Reputation: 16267

Build another dictionary for the months to row lookup

'update sheet2 with numbers from sheet1
arr2 = trgt.Range("A1:F12")

' month to row
Dim dctRow As Dictionary, key As String
Set dctRow = New Dictionary
For j = 4 To UBound(arr1)
    dctRow(Trim(arr1(j, 1))) = j
Next

For j = 2 To 6
    'work backwards to find the column
    strKey2 = Trim(arr2(1, 2)) & "," & Trim(arr2(2, j)) '2 headers
    strKey1 = dctHeader(strKey2)
    col = dctCol(strKey1)
    
    For i = 3 To 12
        key = arr2(i, 1)
        If dctRow.Exists(key) Then
            arr2(i, j) = arr1(dctRow(key), col)
        End If
    Next
Next

Upvotes: 1

Related Questions