![](/img/trans.png)
[英]Excel VBA - insert rows from range to array based on criteria; then populate certain ranges on another sheet with data from array
[英]Grab certain rows from main array to insert into another array to copy into a target sheet
我有一个很大的电子表格,可以解析为其他电子表格。 我有一些工作,虽然很慢。
我读到使用数组是一种更好的方法。
如何从主数组中获取某些行并将它们插入另一个数组中以在最后复制到目标表中?
以下是原始的工作功能:
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
在 VBA 中迭代数组不一定比迭代第一个方法使用的集合对象快。 集合很可能实现为链表,因此为了从头开始并循环遍历它们,它们将与数组一样快。
高层次的答案是,您的排序算法通常比您的特定代码细节重要得多。 也就是说,只要您的详细信息不会以某种方式增加运行该算法的复杂性。
根据我的经验,加速 VBA 的最好方法是避开所有对 UI 有影响的函数。 如果您的代码在所选单元格周围移动,或切换当前查看的工作表等,这就是最大的时间点。 我认为这些函数Select
、 Copy()
和PasteSpecial()
可能对此感到内疚。 最好存储工作表和范围对象,并根据需要直接写入它们的单元格。 您在第二种方法中执行此操作,我认为这比更改数据类型重要得多。
我同意@Seth Battin,但还有一些额外的东西要补充。
虽然数组可以更快,但如果您需要搜索它们,它们就不能很好地扩展。 您编写的代码将遍历您的数据集 n 次(其中 n 是您拥有的TOSHEET
的数量)。 此外,您的代码为每一行将数据写入工作表一次(这很耗时),将所有数据放入单个二维数组并写入一次会更快(但代码更多)。
更好的程序流程可能是
读取每一行数据
将其分配给数据结构(我将使用包含二维数组的脚本字典)
读取所有数据后,迭代输出每个二维数组的脚本字典
这将最大限度地减少对电子表格的读取和写入,这是此类 vba 程序的性能瓶颈所在。
是的。 您肯定会通过使用数组而不是单元格集合来加速您的代码。 这是因为访问对象的属性需要时间。
老实说,您的代码可能不会从使用数组中受益很多,因为您的代码通过消除不必要的循环而得到更合理的修改。
我已经以一种更加以 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)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.