如何在多个列的数组中执行 Application.Match 函数

Question

我目前有一个 VBA 代码，我使用 Application.Match 函数在主表和多个数据表之间进行多次查找。如果其中一个子表中的查找匹配，我将相应的值粘贴到主表中。我对主表中的十二列执行此操作（每个月一列）。

我的代码运行速度非常慢，我怀疑这是因为我没有使用数组，因此在运行代码时会在单个单元格中进行大量打印。我想使用数组来提高性能，但我真的不知道如何将现有代码（我在 for 循环中粘贴到范围的地方）转换为打印到数组。

我的代码如下所示：

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

    With aSheet
    
    For i = FindEmptyRow To FindRow
        mtchrw = 0
        On Error Resume Next
            mtchrw = Application.WorksheetFunction.Match(.Range("A" & i), Sheets("datasheet1").Range("A:A"), 0)
        On Error GoTo 0
        If mtchrw > 0 Then
            Sheets("datasheet1").Range("B" & mtchrw & ":B" & mtchrw).Copy
                .Range("B" & i & ":B" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("C" & mtchrw & ":C" & mtchrw).Copy
                .Range("D" & i & ":D" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("D" & mtchrw & ":D" & mtchrw).Copy
                .Range("F" & i & ":F" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("E" & mtchrw & ":E" & mtchrw).Copy
                .Range("H" & i & ":H" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("F" & mtchrw & ":F" & mtchrw).Copy
                .Range("J" & i & ":J" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("G" & mtchrw & ":G" & mtchrw).Copy
                .Range("L" & i & ":L" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("H" & mtchrw & ":H" & mtchrw).Copy
                .Range("N" & i & ":N" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("I" & mtchrw & ":I" & mtchrw).Copy
                .Range("P" & i & ":P" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("J" & mtchrw & ":J" & mtchrw).Copy
                .Range("R" & i & ":R" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("K" & mtchrw & ":K" & mtchrw).Copy
                .Range("T" & i & ":T" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("L" & mtchrw & ":L" & mtchrw).Copy
                .Range("V" & i & ":V" & i).PasteSpecial Paste:=xlPasteValues 
            Sheets("datasheet1").Range("M" & mtchrw & ":M" & mtchrw).Copy
                .Range("X" & i & ":X" & i).PasteSpecial Paste:=xlPasteValues 
        End If
    Next i
End With

在我的数据表中，这些列彼此相邻，而在我的主表中，每列之间都有一列。这就是我将复制/粘贴功能分成十二部分的原因，如果这有意义的话。

我将如何使用数组来完成这项任务，避免在十二部分中执行复制/粘贴功能？

我为我的英语道歉。这不是我的第一语言。

亲切的问候， 马格努斯

编辑： FindRow 和 FindEmptyRow 反映了 aSheet 中 A 列的第一行和最后一行。 工作表的快照

datasheet1 的快照：

datasheet1 中的值在粘贴到主表之前乘以 37。

Answer 1

试试这个。

Sub CopyValues()
    Dim rw As Integer: rw = 0
    Dim ws1 As Worksheet: Set ws1 = Sheets("Master")
    Dim ws2 As Worksheet: Set ws2 = Sheets("datasheet1")
    Dim nRng As Range: Set nRng = ws1.Range("A3", ws1.Range("A3").End(xlDown))
    Dim vRng As Range, nCell As Range
    Dim i As Integer, col As Integer: col = 3
    
    Dim arr As Variant
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    For Each nCell In nRng
        On Error Resume Next
            rw = Application.WorksheetFunction.Match(nCell, ws2.Range("A:A"), 0)
        On Error GoTo 0
        
        ' If match found
        If rw > 0 Then
            ' copy range of values to array
            Set vRng = ws2.Range(ws2.Cells(rw, 2), ws2.Cells(rw, 13))
            arr = Application.Transpose(Application.Transpose(vRng))
            
            ' Loop through array and copy values
            For i = 1 To UBound(arr)
               ws1.Cells(nCell.Row, col).Value = arr(i)
               col = col + 2
            Next i
        End If
        
        ' Restore inicial values
        rw = 0
        col = 3
    Next nCell
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub