Question

我有两张纸。表1是列的映射，而表2是数据。我想使用Sheet 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

以下是输出的屏幕截图。

如果您想下载，请点击此处Test Stub。

如何通过映射使用VBA将数据从一个工作表复制到另一个工作表

1 个答案: