具有多个项目的映射表

Question

我有一个映射表，用于匹配两个单独工作表（Sheet1 和 Sheet2）的标题。 但是如果我有这样的东西（左侧 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$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
  

  结束于 结束子

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$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

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

请进行测试并发送一些反馈。

Answer 2

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

工具->参考-> Microsoft Scripting Runtime

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

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