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

Question

我有一个代码，它从工作表 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

我在 BU:BW 中有一个名为“映射”的工作表。 因此，如果在 sheet 1 中我的标题是 id ，我想在 sheet2 中找到 segment1 并从 sheet1 中粘贴数据，标题 id。

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

Answer 1

您可以使用VLOOKUP 检索要查找的实际标头。

通过将lkup 声明为变体，即VLookup 要返回的值，并使用Application.VLookup，您可以测试是否使用IsError 找到了值。您还可以使用scripting.dictionary 和.Exists 方法通过键检索映射值；这将是 src 标头。

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

显然，您可以稍微重构一下，例如，将查找范围拉出，以便将其作为变量传递给子 stack。我还可以将名称 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

---

Sheet3 中的数据（查找表）：

---

版本 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