如何通过使用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

这是输出的屏幕截图。

如果您想下载它，这是我的测试存根 。