Replace Headers name in the first row from the cells column of another sheet

Question

I am trying to achieve the following automation in VBA. I have different Sheets with wrong headers. I have another sheet called "HeadersMap", which contains the list of all Sheets's correct headers. What I want to do is, if I open a "Sheet1" then the code should go to the "HeadersMap" sheet > check the opened sheet name in the "SheetNames" column > check the Original header in "OriginalHeaders" column and copy correct header name from the "Correct Headers" column and replace the headers in the "Sheet1". And similarly , if I open "Sheet2", it should do the same.

"SHEET1"

	A	B	C
1	aplpe	baanann	Roange
2
3

SHEET "HEADERSMAP"

	A	B	C
1	SheetNames	OriginalHeaders	CorrectHeaders
2	Sheet1	aplpe	Apple
3	Sheet1	baanann	Banana
4	Sheet1	Roange	Orange
5	Sheet2	sgura	Sugar
6	Sheet2	Jggaery	Jaggery
7	Sheet3	Dtergetn	Detergent
8	Sheet3	poas	Soap
9	Sheet3	Lfua	Lufa

Desired Result "SHEET1"

	A	B	C
1	Apple	Banana	Orange
2
3

Answer 1

Try,

Sub test()
    Dim Ws As Worksheet
    Dim vDB As Variant
    Dim rngHeader As Range
    Dim i As Integer
    
    Set Ws = Sheets("HEADERSMAP")
    
    vDB = Ws.Range("a1").CurrentRegion
    
    For i = 2 To UBound(vDB, 1)
        If isHas(vDB(i, 1)) Then
            Set Ws = Sheets(vDB(i, 1))
            Set rngHeader = Ws.Rows(1)
            rngHeader.Replace vDB(i, 2), vDB(i, 3)
        End If
    Next i
End Sub
Function isHas(v As Variant) As Boolean
    Dim Ws As Worksheet
    For Each Ws In Worksheets
        If Ws.Name = v Then
            isHas = True
            Exit Function
        End If
    Next Ws
End Function

Answer 2

Correct Headers

Edit

• After reading your comment, it may be best to copy the complete code to the ThisWorkbook module (if you insist on this functionality). There is no need for adding another module.

---

• It is assumed that the data in worksheet HeadersMap starts in cell A1.

Standard Module e.g. Module1

Option Explicit

Sub correctHeaders(ws As Worksheet)
    
    Const sName As String = "HeadersMap"
    Const sFirst As String = "A1"
    
    Dim rg As Range
    Dim Data As Variant
    
    Set rg = ThisWorkbook.Worksheets(sName).Range(sFirst).CurrentRegion
    If IsNumeric(Application.Match(ws.Name, rg.Columns(1), 0)) Then
    
        Data = rg.Value
        
        Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
        Dim Result() As Variant
        Dim r As Long, j As Long
        For r = 1 To UBound(Data, 1)
            If StrComp(Data(r, 1), ws.Name, vbTextCompare) = 0 Then
                j = j + 1
                ReDim Preserve Result(1 To 2, 1 To j)
                Result(1, j) = Data(r, 2)
                Result(2, j) = Data(r, 3)
            End If
        Next r
        
        If j > 0 Then
            Set rg = ws.UsedRange.Rows(1)
            Data = rg.Value
            Dim cIndex As Variant
            For j = 1 To j
                cIndex = Application.Match(Result(1, j), Data, 0)
                If IsNumeric(cIndex) Then
                    Data(1, cIndex) = Result(2, j)
                End If
            Next j
            rg.Value = Data
        End If
    
    End If

End Sub

Additional Functionality (you have to run it)

Sub correctHeadersApply
    Dim ws As Worksheet
    For Each ws in Thisworkbook.Worksheets
        correctHeaders ws
    Next ws
End Sub        

ThisWorkbook Module

Option Explicit

Private Sub Workbook_Open()
    correctHeaders ActiveSheet
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Type = xlWorksheet Then
        correctHeaders Sh
    End If
End Sub

Answer 3

Bare minimum would probably be putting this in ThisWorkbook:

Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim targetRange As Range, i As Long
Set targetRange = Worksheets("HEADERSMAP").Range("A1:A9")
i = 1
    For Each entry In targetRange
        If entry.Value = Sh.NAME Then
            Sh.Cells(1, i) = entry.Offset(, 2).Value
            i = i + 1
        End If
    Next
End Sub

If the data is looking like your examples. Later you might want ot change Range("A1:A9") to look for the last row, and Offset(, 2) to maybe Offset(, 1) since the "OriginalHeaders" column is superflous in reality.

The Module version would be something like:

Sub headers()
Dim targetRange As Range, i As Long, Sh As Worksheet
Set Sh = Worksheets(InputBox("Enter name of sheet"))
Set targetRange = Worksheets("HEADERSMAP").Range("A1:A9")
i = 1
    For Each entry In targetRange
        If entry.Value = Sh.NAME Then
            Sh.Cells(1, i) = entry.Offset(, 2).Value
            i = i + 1
        End If
    Next
End Sub

That is if the name of the sheet and the item in the list correlate. You could set a second variable with a second inputbox, and replace Sh.NAME to select from the list manually. Like so:

Sub headers()
Dim targetRange As Range, i As Long, Sh As Worksheet, name As String
Set Sh = Worksheets(InputBox("Enter name of sheet"))
name = InputBox("Enter name from map")
Set targetRange = Worksheets("HEADERSMAP").Range("A1:A9")
i = 1
    For Each entry In targetRange
        If entry.Value = name Then
            Sh.Cells(1, i) = entry.Offset(, 2).Value
            i = i + 1
        End If
    Next
End Sub

Then you can manually type witch sheet get what headers, if you like to do that.