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 |
+----------+-----------------+------------+
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
Tags: excelexcel, vba