Home » excel » excel – VBA, Add mapping table to change header name

excel – VBA, Add mapping table to change header name

Posted by: admin May 14, 2020 Leave a comment

Questions:

I have a code that takes headers from sheet 1 with its data, finds those headers in sheet 2 and pastes the data where headers match between sheets.

But what if my headers from sheet 1 does not exist in sheet 2, I want to include a mapping table in another sheet which translates unlike headers into like headers. But I want to explicilty list these headers in a mapping table.
I am having trouble finding the mapping then pasting into the new headers, as I dont want to replace or change the headers in my sheet 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

i have a sheet named “mappings” like so, in BU:BW.
So if in sheet 1 my header is id , I want to find segment1 in sheet2 and paste the data there from sheet1 , header id.

+----------+-----------------+------------+
| Tab Name | Original Header | New Header |
+----------+-----------------+------------+
| sheet1   | id              | segment1   |
| sheet1   | id2             | segment2   |
+----------+-----------------+------------+
How to&Answers:

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):

Lkup


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