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检索要查找的实际 header 。

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

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

显然，您可以稍微重构一下，例如，将查找范围拉出，以便将其作为变量传递给子 stack .我可能还会更改名称 stack更能描述 sub 所做的事情。我添加了动态查找查找表的最后一行，以避免硬编码范围的末尾。如果您添加更多查找键值对。

代码:

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