映射 table 与多个项目

Question

我有一个映射 table，用于匹配两个单独工作表（Sheet1 和 Sheet2）的 headers。但是，如果我有这样的东西（左边 3 列，右边 2 列）怎么办：

基本上我希望 POS1 2019 EMP1 等于 HR DEPARTMAENT Employee1 等等。 Sheet1, Sheet2, Mapping 任何想法我该怎么做？先感谢您！ :)

 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:$F").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

结束于结束子

Answer 1

请尝试下一个改编代码。

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:$F").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

请同时更正调用第二个的子。你在那里混合了“Shee2”和“Sheet1”...

请测试它并发送一些反馈。

Answer 2

我认为字典是最适合这类问题的数据结构。请注意，要在 VBA 中使用字典，您需要设置对脚本运行时库的引用。

工具->参考-> Microsoft 脚本运行时

下面是一些适用于您提供的示例的代码：

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

映射 table 与多个项目

Mapping table with multiple items

mapping

vba

dictionary

header

match