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

Question

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

我的代码运行非常慢，我怀疑这是因为我没有使用数组，因此在运行代码时会在单个单元格中进行大量打印。我想使用数组来提高性能，但我真的不知道如何将我在 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

在我的数据sheet中，列彼此相邻，而在我的主数据sheet中，每列之间有一列。这就是我将 copy/paste 函数分成十二个部分的原因，如果这样的话。

我将如何使用数组来完成这项任务，避免在十二部分中执行 copy/paste-函数？

我为我的英语道歉。这不是我的母语。

亲切的问候，马格努斯

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

数据快照sheet1：

数据sheet1 中的值在粘贴到主文件之前乘以 37 sheet。

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

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

How to perform Application.Match function in an array for multiple columns

arrays

excel

vba

match

lookup