匹配行 headers

Question

我有一个映射 table，用于匹配两个单独工作表（Sheet1 和 Sheet2）的列 headers。但是当我还想匹配行 headers （月）时，代码匹配行，而不是 A 列上的单元格。我有什么想法可以使它工作吗？先感谢您！ :)

Sheet1- src:

Sheet2- trgt（我运行代码后，应该也匹配Oct, Nov, Dec）：

,

映射table:

Sheet2- 我需要的：

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

Answer 1

为月份行查找构建另一个字典

'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

匹配行 headers

Matching row headers

excel

vba

mapping

match

rowheader