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中有一个名为“ mappings”的工作表。因此，如果在工作表1中，我的标头是id，我想在工作表2中找到segment1，然后将数据从工作表1的标头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

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

1 个答案: