VBA，添加映射表以更改标题名称

我有一个代码，它从表1中获取标题及其数据，在表2中查找这些标题，并将数据粘贴到表之间标题匹配的位置

但是，如果工作表1中的标题在工作表2中不存在，我希望在另一个工作表中包含一个映射表，该表将不同的标题转换为相似的标题。但我想在映射表中明确列出这些头。 我很难找到映射，然后粘贴到新的标题中，因为我不想替换或更改工作表1中的标题

Option Explicit
Sub stack(from_ws, to_ws, mapping)
    Dim rng As Range, trgtCell As Range
    Dim src As Worksheet
    Dim trgt As Worksheet
    Dim helper As Worksheet
    Set src = Worksheets(from_ws)
    Set trgt = Worksheets(to_ws)
    Set helper = Worksheets(mapping)
    Application.ScreenUpdating = False

    With src
        For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)

            'mapping code to go here

            Set trgtCell = trgt.Rows(1).Find(rng.value, 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) & .Cells(.Rows.count, trgtCell.Column).End(xlUp).row + 1).PasteSpecial
                End With
            End If
        Next rng
    End With
    Application.ScreenUpdating = False
End Sub

我有一个名为“mappings”的工作表，类似这样，在BU:BW中。 因此，如果在第1页中，我的标题是id，我想在第2页中找到分段1，并将数据从第1页标题id粘贴到那里

+----------+-----------------+------------+
| Tab Name | Original Header | New Header |
+----------+-----------------+------------+
| sheet1   | id              | segment1   |
| sheet1   | id2             | segment2   |
+----------+-----------------+------------+

---

您可以使用

VLOOKUP

检索要查找的实际标头

通过将

lkup

声明为variant，由

VLookup

返回的值，并使用

Application.VLookup

，您可以使用

iError

测试是否找到值。您还可以使用

脚本.dictionary

和

.Exists

方法按键检索映射值；这将是

src

标题

您希望您的查找范围是全面的。在我给出的示例中，请注意，它不仅包含新名称，而且还包含名称是否保持不变

显然，您可以对其进行一些重构，例如，拉出查找范围，以便将其作为变量传递给子

堆栈。我还可以将名称
stack
更改为更具描述性的子功能。我添加了动态查找查找表的最后一行，以避免硬编码范围的末尾。以防添加更多查找键值对

代码：

Option Explicit
Public Sub test()
    Application.ScreenUpdating = False
    stack "Sheet1", "Sheet2", "Sheet3"
    Application.ScreenUpdating = True
End Sub

Public Sub stack(ByVal from_ws As String, ByVal to_ws As String, ByVal mapping As String)
    Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As Worksheet, helper As Worksheet
    Set src = Worksheets(from_ws)
    Set trgt = Worksheets(to_ws)
    Set helper = Worksheets(mapping)

    With src
        For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)
            Dim lkup As Variant
            With helper
                lkup = Application.VLookup(rng.Value, .Range("A2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row), 2, False)
            End With
            If Not IsError(lkup) Then
                Set trgtCell = trgt.Rows(1).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) & .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1).PasteSpecial
                    End With
                End If
            End If
        Next rng
    End With
End Sub


表3（查阅表）中的数据：



第2版：

以下是使用字典处理替换的版本：

Option Explicit
Public Sub test()
    Application.ScreenUpdating = False
    Dim headerDict As Object
    Set headerDict = CreateObject("Scripting.Dictionary")
    headerDict.Add "id1", "segment1"
    headerDict.Add "id2", "segment2"
    headerDict.Add "id3", "segment3"

    stack "Sheet1", "Sheet2", headerDict
    Application.ScreenUpdating = True
End Sub

Public Sub stack(ByVal from_ws As String, ByVal to_ws As String, dictHeader As Object)
    Dim rng As Range, trgtCell As Range, src As Worksheet, trgt As Worksheet
    Set src = Worksheets(from_ws)
    Set trgt = Worksheets(to_ws)
    With src
        For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)
            If dictHeader.exists(rng.Value) Then
                Set trgtCell = trgt.Rows(1).Find(dictHeader(rng.Value), LookIn:=xlValues, lookat:=xlWhole)
            Else  
                Set trgtCell = trgt.Rows(1).Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)
            End If
            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) & .Cells(.Rows.Count, trgtCell.Column).End(xlUp).Row + 1).PasteSpecial
                End With
            End If
    Next rng
End With
End Sub