excel – VBA, Add mapping table to change header name

You could use VLOOKUP to retrieve the actual header to look for.

By declaring lkup as variant, the value to be returned by the VLookup, and using Application.VLookup, you can test whether a value was found using IsError. You could also use a scripting.dictionary and .Exists method to retrieve mapped value by key; which would be the src header.

You would want your lookup range to be comprehensive. In the example I give, note how it is not just new names covered but also if the name remains the same.

Obviously, you could refactor this a bit and, for example, pull the lookup range out so it is passed in as a variable to the sub stack. I might also change the name stack to something more descriptive of what the sub does. I have added in dynamically finding the last row of the lookup table so as to avoid hardcoding the end of the range. In case you add more lookup key value pairs.

Code:

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

Data in Sheet3 (lookup sheet):

Version 2:

Here is a version using a dictionary to handle the replacement:

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