如何通过使用VBA映射将数据从一张纸复制到另一张纸

Question

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

Answer 1

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.