2

我有一个很大的电子表格，我会解析为其他电子表格。我有一些工作，虽然很慢。

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

如何从主数组中获取某些行并将它们插入另一个数组以在最后复制到目标表中？

以下是原始的工作功能：

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
4

3 回答 3

4

在 VBA 中迭代数组不一定比迭代第一个方法使用的集合对象快。集合很可能被实现为链表，因此为了从头开始并循环它们，它们将与数组一样快。

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

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

于 2012-12-31T01:07:31.667 回答
1

我同意@Seth Battin 的观点，但还有一些额外的东西要补充。

虽然数组可以更快，但如果您需要搜索它们，它们的扩展性并不好。您编写的代码将遍历您的数据集 n 次（其中 n 是TOSHEET您拥有的 s 的数量）。此外，您的代码为每一行将数据写入工作表一次（这很耗时），将所有数据放入单个二维数组并写入一次会更快（但代码更多）。

更好的程序流程可能是

读取每一行数据

将其分配给数据结构（我会使用包含二维数组的脚本字典）

读取所有数据后，迭代输出每个二维数组的脚本字典

这将最大限度地减少对电子表格的读取和写入，这是此类 vba 程序的性能瓶颈所在。

于 2012-12-31T02:15:34.523 回答
0

是的。您肯定会通过使用数组而不是单元格集合来加速您的代码。这是因为访问对象的属性需要时间。

老实说，您的代码可能不会从使用数组中受益匪浅，因为您的代码通过消除不必要的循环得到了更合理的修改。

我以更加以 Excel 为中心的方式重写了 RESORT 函数的开头，避免了一些陷阱，例如选择。我还建议尝试使用有意义的变量名，尤其是对于对象。

OPTION EXPLICIT
Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
'Actually indicate variable types.
dim i as worksheet, dim e as worksheet
dim searchRange as Range

Set i = Sheets(FROMSHEET)
Set e = Sheets(TOSHEET)


Dim d as long
Dim j as long
dim lastRow as long 'Using a meaningful variable name
d = 1
j = 2

'I'm assuming you were using PasteSpecial because you only want values.
'I removed your unnecessary selects
e.Cells.Clear
'Move values directly instead of copy paste
i.Rows(1).value = e.Rows(1).value

'Check the first range
If Not IsEmpty(.Range("G" & j)) Then
    'Determine the last row to check.
    'This would break if j is equivalent to the last possible row... 
    'but only an example
    If IsEmpty(.Range("G" & j+1) then
        lastRow = j
    else 
        lastrow = i.Range("G" & j).End(xlDown).Row
    end if
    'Get the search Range
    'We might have used arrays here but it's less complicated to 
    ' use built in functions.
    Set searchRange = i.Range(i.Range(Column & j), _
                      i.Range(Column, lastrow).Find("Total"))
    If Not (searchRange Is Nothing) Then
        'Copy the values of the found row.
        e.Rows(2).value = searchRange.EntireRow.value
    End If
End If

这样做之后，我意识到可能更合理地使用数组的部分是在我停止的地方之后。如果你想在这里使用数组，你需要做的是有效地将所有相关区域复制到一个数组中，然后像引用单元格一样引用数组。

例如：

myArray = i.Range("A1:B10")
MsgBox myArray(10, 2) 'Displays value of B10 (10th row, 2nd column)
MsgBox i.Cells(10, 2) 'Displays value of B10 (10th row, 2nd column)
于 2012-12-31T04:27:37.807 回答