arrays - 从主数组中抓取某些行以插入另一个数组以复制到目标表中

Question

我有一个大电子表格，我将其解析为其他电子表格。我有一些东西在工作，尽管速度很慢。

我读到过使用数组是一种更好的方法。

我如何从主数组中抓取某些行并将它们插入到另一个数组中以在末尾复制到目标工作表中？

这里是原始的、有效的函数:

Private Function CopyValues(rngSource As Range, rngTarget As Range)
    rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
End Function
    
Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
    Set i = Sheets(FROMSHEET)
    Set e = Sheets(TOSHEET)
    
    Dim d
    Dim j
    Dim q
    d = 1
    j = 2
    
    e.Select
    Cells.Select
    Selection.Clear
    i.Select
    Rows(1).Copy
    e.Select
    Rows(1).PasteSpecial
    
    Do Until IsEmpty(i.Range("G" & j))
        If i.Range(Column & j) = "Total" Then
            i.Select
            Rows(j).Copy
            e.Select
            Rows(2).PasteSpecial
            ' CopyValues i.Rows(j), e.Rows(2)
            Exit Do
        End If
        j = j + 1
    Loop
    
    d = 2
    j = 2
    
    Do Until IsEmpty(i.Range("G" & j))
        
        If i.Range(Column & j) = TOSHEET Or i.Range(Column & j) = EXTRA1 Or i.Range(Column & j) = EXTRA2 Or i.Range(Column & j) = EXTRA3 Then
            d = d + 1
            CopyValues i.Range(i.Cells(j, 1), i.Cells(j, 11)), e.Range(e.Cells(d, 1), e.Cells(d, 11)) 'e.Range("A" & d)
            
        ElseIf i.Range("A" & j) = e.Range("A" & d) And i.Range("I" & j) = "Total" Then
            d = d + 1
            e.Select
            Rows(2).Copy
            Rows(d).PasteSpecial
            ' CopyValues e.Rows(2), e.Rows(d)
        End If
        j = j + 1
    Loop
    e.Select
    Rows(2).Delete
    Range("A1").Select
    
End Function

这就是我正在破解的内容，其中有许多不同的尝试:

Private Function RESORT2(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
    ' Set i = Sheets(FROMSHEET)
    ' Set e = Sheets(TOSHEET)
    Dim d
    Dim j As Long
    Dim i As Long
    Dim k As Long
    
    Dim myarray As Variant
    Dim arrTO As Variant
    
    d = 1
    j = 1
          
    'myarray = Worksheets(FROMSHEET).Range("a1").Resize(10, 20)
    myarray = Worksheets(FROMSHEET).Range("a1:z220").Value 'Resize(10, 20)
    For i = 1 To UBound(myarray)
        If myarray(i, 9) = TOSHEET Then
            'arrTO = myarray
            '  Worksheets(TOSHEET).Range("A" & j).Resize(1, 20) = Application.WorksheetFunction.Transpose(myarray(i))
            Worksheets(TOSHEET).Range("A" & j).Value = Application.WorksheetFunction.Transpose(myarray)
            '   arrTO = j 'Application.WorksheetFunction.Index(myarray, 0, 1)

            j = j + 1
                
        End If
            
    Next
    Worksheets(TOSHEET).Range("a1").Resize(10, 20) = arrTO
    
End Function

第一次编辑
我尝试清理:

Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
    Set FRO = Sheets(FROMSHEET)
    Set TOO = Sheets(TOSHEET)
    
    Dim TOO_IND
    Dim FRO_IND
    Dim TotalRow
    
    TotalRow = 2
    TOO_IND = 2
    FRO_IND = 2
    
    TOO.Cells.Clear
    TOO.Rows(1).Value = FRO.Rows(1).Value
    
    Do Until IsEmpty(FRO.Range("G" & TotalRow))
        If FRO.Range(Column & TotalRow) = "Total" Then
            FRO.Select
            Rows(TotalRow).Copy
            TOO.Select
            Rows(2).PasteSpecial
            ' CopyValues FRO.Rows(j), TOO.Rows(2)
            Exit Do
        End If
        TotalRow = TotalRow + 1
    Loop
    
    Do Until IsEmpty(FRO.Range("G" & FRO_IND))
        
        If FRO.Range(Column & FRO_IND) = TOSHEET Or FRO.Range(Column & FRO_IND) = EXTRA1 Or FRO.Range(Column & FRO_IND) = EXTRA2 Or FRO.Range(Column & FRO_IND) = EXTRA3 Then
            TOO_IND = TOO_IND + 1
            TOO.Rows(TOO_IND).Value = FRO.Rows(FRO_IND).Value
        ElseIf FRO.Range("A" & FRO_IND) = TOO.Range("A" & TOO_IND) And FRO.Range("I" & FRO_IND) = "Total" Then
            TOO_IND = TOO_IND + 1
            TOO.Select
            Rows(2).Copy
            Rows(TOO_IND).PasteSpecial
         '   TOO.Rows(TOO_IND).PasteSpecial = FRO.Rows(2).PasteSpecial  ' this isn't working, I need format and formula, if I just do .formula it doesn't work
        End If
        FRO_IND = FRO_IND + 1
    Loop
    
    TOO.Rows(2).Delete
    'Range("A1").Select
    
End Function

速度较慢(在我的最小样本集上为 3.2 秒，而 2.86 秒)。

我认为阵列将成为解决方案。我在同一个样本集上多次运行这个例程，但使用不同的限定符，如果在主要情况下我将样本集转储到一个数组中，然后将这个数组传递给这个排序例程，我认为它会更快。我仍然不知道如何对数组进行操作，特别是将一行从一个数组复制到另一个数组。

第二次编辑
我现在更接近了!过去大约需要 133 秒，现在只需要 10.51 秒!

我还在尝试整理一些时间。我还没有编写任何代码来一次获取数组，然后将数组传递给 RESORT 函数，接下来我正在研究它是否有助于加快速度。

有没有办法将公式和值复制到同一个数组中？我不喜欢我这样做的方式，但它确实有效。

Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
    Set FRO = Sheets(FROMSHEET)
    Set TOO = Sheets(TOSHEET)
    
    Dim TotalRow
    
    TotalRow = 2
    TOO_IND = 2
    FRO_IND = 2
    
    Dim Col As Long
    Dim FROM_Row As Long
    Dim TO_Row As Long
    
    Const NumCol = 25
    
    Dim myarray As Variant
    Dim myarrayform As Variant
    Dim arrTO(1 To 1000, 1 To 2000)
    Dim arrTotal(1 To 1, 1 To NumCol)
    
    TO_Row = 2
    myarray = Worksheets(FROMSHEET).Range("a1:z1000").Value
    myarrayform = Worksheets(FROMSHEET).Range("a1:z1000").FormulaR1C1
    
    TOO.Cells.Clear
    
    For Col = 1 To NumCol
        arrTO(1, Col) = myarray(1, Col)
    Next
    
    For FROM_Row = 1 To UBound(myarray)
        If myarray(FROM_Row, Column) = "Total" Then
            For Col = 1 To NumCol
                arrTotal(1, Col) = myarrayform(FROM_Row, Col)
            Next
            Exit For
        End If
    Next
    
    For FROM_Row = 1 To UBound(myarray)
        If myarray(FROM_Row, Column) = TOSHEET Or myarray(FROM_Row, Column) = EXTRA1 Or myarray(FROM_Row, Column) = EXTRA2 Or myarray(FROM_Row, Column) = EXTRA3 Then
            For Col = 1 To NumCol
                arrTO(TO_Row, Col) = myarray(FROM_Row, Col)
            Next
            TO_Row = TO_Row + 1
        ElseIf myarray(FROM_Row, 1) = arrTO(TO_Row - 1, 1) And myarray(FROM_Row, Column) = "Total" Then
            For Col = 1 To NumCol
                arrTO(TO_Row, Col) = arrTotal(1, Col)
            Next
            TO_Row = TO_Row + 1
        End If
    Next
    Worksheets(TOSHEET).Range("a1").Resize(1000, 2000) = arrTO
    
End Function

Answer 1

在 VBA 中遍历数组不一定比遍历第一个方法使用的集合对象更快。这些集合很可能以链表的形式实现，因此为了从头开始并循环遍历它们，它们将与数组一样快速。

高级答案是您的排序算法通常比您的特定代码细节重要得多。也就是说，只要您的详细信息不会以某种方式增加运行该算法的复杂性。

根据我的经验，加速 VBA 的最佳方法是避开所有对 UI 有影响的函数。如果您的代码在选定的单元格周围移动，或切换主动查看的工作表等，那将是最大的时间消耗。我认为那些函数 Select、Copy() 和 PasteSpecial() 可能是罪魁祸首。最好存储工作表和范围对象，并根据需要直接写入它们的单元格。您在第二种方法中执行此操作，我认为这比更改数据类型重要得多。