如何通過使用VBA映射將數據從一張紙復制到另一張紙

Question

我有兩張。 工作表1是列的映射，工作表2是數據。 我想通過使用工作表1將數據從工作表2復制到新工作表3。工作表1，工作表2如下所示

碼：

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

Function getAlteranteHeaderName(value As String)將查找新的標頭值。 Sub CopyDataRemapHeader()是一個簡單示例，說明如何將范圍從Sheet 2復制到Sheet3 ，然后如果存在備用標頭行名稱，請對其進行更改。

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

這是輸出的屏幕截圖。

如果您想下載它，這是我的測試存根 。