在excelvba中加速处理大容量数据

我正在使用vba获取不同货币的不同帐户的列表。为此，我使用一个普通的过滤器来选择货币，然后使用一个高级过滤器来选择该货币的所有帐户。然后，它将列表粘贴到名为Accts的工作表上

电子表格有超过30000行的信息，速度非常慢，但无论如何都有可能做得更快。我的代码如下。我认为这是可行的，但只需要永远

Sub Filtering()


Application.ScreenUpdating = False

intLastRow = Worksheets("report").Cells(Rows.Count, "b").End(xlUp).Row

intLastCol = Worksheets("info sheet").Cells(Columns.Count, 7).Column

Set rngAdvFilter = Worksheets("report").Range("b7:m" & intLastRow)
Set rngCriteria = Worksheets("report").Range("d7:d" & intLastRow)

Set rRange = Worksheets("info sheet").Range("c7:m7")

For Each rCell In rRange


strCurrency = rCell.Value

With rngAdvFilter
  .AutoFilter Field:=6, Criteria1:= _
    "=" & strCurrency, Operator:=xlAnd 'filtering on currency so we are
    'looking for all accounts on a certain currency
    End With


Worksheets("accts").Select

Range("b1:aa1").Select



Selection.find(What:=strCurrency, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate

    Set rngPaste = ActiveCell.Offset(1, 0)


    rngPaste.Select

Worksheets("report").Select

Range("D7:D" & intLastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
    "P7"), Unique:=True



intLastRow2 = Worksheets("report").Cells(Rows.Count, "p").End(xlUp).Row

Set rngResults = Worksheets("report").Range("P8:P" & intLastRow2)

rngResults.Copy



rngPaste.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

rngResults.ClearContents


If Worksheets("report").FilterMode Then

Worksheets("report").ShowAllData

End If


Next rCell

Application.ScreenUpdating = True

End Sub

---

我想你可能得重新写一写。每个细胞的选择才是真正让事情变慢的原因。我建议从这里开始

我还建议声明所有变量（将“Option Explicit”也放在模块顶部）

---

Lea.

这肯定会运行得非常慢。每次访问电子表格（范围访问）都会减慢速度。实现这一点的方法是通过只访问工作表两次来执行代码。一次是获取数据，另一次是将所需内容放回工作表

e、 g

---

这将使事情加速几个数量级。此外，通常的

应用程序。屏幕更新
等可能会有所帮助，这取决于您在宏中执行的其他操作，但考虑到屏幕上没有太多操作，只有2次访问，这应该非常快。
谢谢。我已经声明了我所有的变量和看跌期权。很难理解你的数据结构或者你想要输出什么。如果LeasMaps建议不起作用，我建议您用数据和所需输出的示例编辑您的问题（或者，更好的是，发布一个指向我们可以下载的工作簿的链接）。有各种各样的方法来加速这个过程。在你录制的宏解码时，很少有评论是很困难的。但是如果要查看第7行的最后一列，您的
intLastCol=Worksheets（“info sheet”）.Cells（Columns.Count，7）。Column
实际上是
intLastCol=7
：intLastCol=Worksheets（“info sheet”）.Cells（7，Columns.Count）。End（xlToLeft）。Column
这可能有点超出了我的VBA理解，但我会深入研究它。非常感谢。我基本上需要用每种货币生成一个帐户列表，并将它们粘贴到一个新的表中，以查看它们是否已经包括在内。这里会有一些公式来检查acct是否在工作表上。是的，虽然这比直接访问范围稍微复杂一些，但速度会快得多，因为您在一个笔划中获取整个范围，处理它，然后在一个笔划中将其抽回工作表中。您可以首先简单地使用一个变量数组获取值，如图所示，然后逐步修改代码。这样做的好处是，由于所有的加速都是在内部进行的，所以代码的其余部分（其他函数、宏）可以保持原样。
Sub ProcessData()
    Dim Rng as Range, OutputRng as Range
    Set Rng = Worksheets("Sheet1").Range("A1:D20000")
    ' Spreadsheet Access # 1
    ' Assuming you want to do something to the data in that range

    Dim InputDat as Variant, OutputDat() as Variant
    InputDat = Rng
    ' Now InputDat has become a Variant array of size 20000 x 4

    ' Code to manipulate Dat goes here        

    Redim OutputDat(1 to 100, 1 to 4)    'Or dynamically as needed
    ' Put required output data into OutputDat as if it's the range
    ' where your answers appear following the correct row/column number

    Set OutputRng = Worksheets("Sheet2").Range("A1:D100")
    OutputRng = OutputDat
    ' Spreadsheet access #2
End Sub