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 |
Edit
ThisWorkbook
module (if you insist on this functionality). There is no need for adding another module.HeadersMap
starts in cell A1
. Standard Module eg 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
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
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.