I have two sheets. Sheet 1 is Mapping of column and Sheet 2 is Data. I wants to copy data from sheet 2 to new sheet 3 by using Sheet 1. sheet 1,Sheet 2 is shown below
Code:
Sub ModdedMap()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim HeadersOne As Range, HeadersTwo As Range
Dim hCell As Range
With ThisWorkbook
Set Sh1 = .Sheets("Sheet 1") 'Modify as necessary.
Set Sh2 = .Sheets("Sheet 2") 'Modify as necessary.
Set Sh3 = .Sheets("Sheet3") 'Modify as necessary.
End With
Set HeadersOne = Sh3.Range("P2:P" & Sh3.Range("Q" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
For Each hCell In HeadersOne
SCol = GetColMatched(Sh1, hCell.Value)
TCol = GetColMatched(Sh2, hCell.Offset(0, 1).Value)
LRow = GetLastRowMatched(Sh1, hCell.Value)
For Iter = 2 To LRow
Sh2.Cells(Iter, TCol).Value = Sh1.Cells(Iter, SCol).Value
Next Iter
Next hCell
Application.ScreenUpdating = True
ActiveWorkbook.Sheets(3).Activate
End Sub
Function GetLastRowMatched(Sh As Worksheet, Header As String) As Long
ColIndex = Application.Match(Header, Sh.Rows(1), 0)
' On Error Resume Next
GetLastRowMatched = Sh.Cells(Rows.Count, ColIndex).End(xlUp).Row
End Function
Function GetColMatched(Sh As Worksheet, Header As String) As Long
ColIndex = Application.Match(Header, Sh.Rows(1), 0)
'On Error Resume Next
GetColMatched = ColIndex
' On Error Resume Next
End Function
The Function getAlteranteHeaderName(value As String)
will lookup the new header value. Sub CopyDataRemapHeader()
is a minimalistic example of how you can copy a range from Sheet 2
to Sheet3
and then if an alternate header row name exists change it.
Sub CopyDataRemapHeader()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim HeadersRow As Range, hCell As Range
Dim newName As String
Set Sh1 = Sheets("Sheet 1")
Set Sh2 = Sheets("Sheet 2")
Set Sh3 = Sheets("Sheet3")
With Sh3
Sh2.Range("A1").CurrentRegion.Copy .Range("A1")
Set HeadersRow = Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft))
For Each hCell In HeadersRow
newName = getAlteranteHeaderName(hCell.Text)
If Len(newName) Then hCell.value = newName
Next hCell
End With
End Sub
Function getAlteranteHeaderName(value As String) As String
Dim rOld As Range, rNew As Range
With Worksheets("Sheet 1")
Set rNew = Intersect(.Range("A:A"), .UsedRange)
Set rOld = Intersect(.Range("B:B"), .UsedRange)
On Error Resume Next
getAlteranteHeaderName = WorksheetFunction.Index(rNew, WorksheetFunction.Match(value, rOld, 0))
On Error GoTo 0
End With
End Function
Here is a screenshot of the output.
Here is my Test Stub if you would like to download it.
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.