VBA根据参考单元格中的匹配值将数据从一个范围移动到另一个图纸范围

Question

在工作表1上，我在A1中有一个值，在A5：A11，B5：B11中有一个表。

A5：A11是与sheet2 B1：G1匹配的标题。 A：A是A1的匹配值列表。

B5：B11是我要移到sheet2的列中的值，其标题与sheet2的行中的A5：A11匹配，并且其列A：A中的值来自A1。

这是一些以前建议的实现此目的的代码，但是它不起作用，但我认为它已经可以正常工作了。

Sub moveData()
    Dim rS As Range
    Dim rT As Range
    Dim Cel As Range
    Dim lRow As Long

    With Sheet1
        lRow = .Range("a1").Value
        Set rS = .Range("A5", .Cells(.Rows.CountLarge, 1).End(xlUp)) 'source headings
    End With
    With Sheet2
        Set rT = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)) 'target headings
    End With

    'find matching heading Sheet2, copy data to specified row
    On Error Resume Next 'skip over non-matches
    For Each Cel In rS
        Sheet2.Cells(lRow, rT(Application.Match(Cel.Value, rT, 0)).Column).Value = Cel.Offset(, 1).Value
    Next Cel
End Sub

Answer 1

Sub tgr()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim VisCell As Range
    Dim lCalc As XlCalculation

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")

    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    With Intersect(ws2.UsedRange, ws2.Columns("A"))
        .AutoFilter 1, ws1.Range("A1").Text
        On Error Resume Next
        For Each VisCell In .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Cells
            ws1.Range("B5:B11").Copy
            VisCell.Offset(, 1).PasteSpecial xlPasteValues, Transpose:=True
        Next VisCell
        On Error GoTo 0
        .AutoFilter
    End With

    With Application
        .Calculation = lCalc
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub