VBA加速代码

从假期回来，我发现自己很有动力去加速去年写的VBA代码。 基本数据是公司所做或想要做的一系列措施。 我的工作是创build一个macros，让一些员工从这个非常不舒服的列表中获得某些信息。

一开始我对VBA相当陌生，但是很快学会了基础知识。 现在的问题是，一些程序耗时过长。 大多数情况下，实际上在整个程序中，我使用了一些我知道让macros变慢的东西，但是那样我需要你的帮助，我不知道如何改善。

例如：

有一个UserForm应该提供一个简单的方法来导出一个过滤列表。 直到现在让员工select他想要过滤的内容，然后使用自动filter过滤列表，然后将可见单元复制到另一个工作表中。 很明显，我使用了一些像自动filter这样的macros，比使用数组要慢得多。

编辑：一些示例代码。 这很难，因为我使用了很多模块和function，因为这是一个相当大的项目，但我会尽力向你展示。 我希望你能理解，因为名字和variables显然是德语。

这就是我所说的使用自动筛选器来过滤Excel表格的函数。

'Firma = company If .chkFirma.Value = True Then Call Maßnahmen.FilterAnlegen(Spalte:=Maßnahmen.SpalteFirma, Kriterium:=Firma) Call DateiBenennen("-" & Firma) End If 'Anlass = something like "reason" If .chkAnlass.Value = True Then Call Maßnahmen.FilterAnlegen(Spalte:=Maßnahmen.SpalteAnlass, Kriterium:=Anlass) Call DateiBenennen("-" & Anlass) End If 'Spezifizierung = specification If .chkSpezifizierung.Value = True Then Call Maßnahmen.FilterAnlegen(Spalte:=Maßnahmen.SpalteSpezifizierung, Kriterium:=Spezifizierung) Call DateiBenennen("-" & Spezifizierung) End If 'Kunde = customer If .chkKunde.Value = True Then Call Maßnahmen.FilterAnlegen(Spalte:=Maßnahmen.SpalteKunde, Kriterium:=Kunde) Call DateiBenennen("-" & Kunde) End If 

这里函数FilterAnlegen：

 Sub FilterAnlegen(Spalte As Integer, Optional Kriterium As String, Optional Kriterien As Collection) Dim KritArray() If Kriterien Is Nothing And Kriterium = "" Then Exit Sub With Maßnahmen .Activate If Not Kriterien Is Nothing Then ReDim KritArray(Kriterien.Count - 1) For i = 0 To Kriterien.Count - 1 KritArray(i) = Kriterien(i + 1) Next i 'Filter anlegen .ListObjects("TabelleMaßnahmen").Range.AutoFilter Field:=Spalte, Criteria1:=KritArray, Operator:=xlFilterValues ElseIf Kriterium <> "" Then .ListObjects("TabelleMaßnahmen").Range.AutoFilter Field:=Spalte, Criteria1:=Kriterium End If End With End Sub 

我的问题基本上是wheatherarrays将是这个最好的解决scheme，你将如何解决这个问题。 但还有其他一些问题随之而来。 由于这是一个Excel表多个列，我将需要一个multidimensional array。 这比一维的慢吗？

如果有什么你不明白的东西或者我需要澄清的一些东西只是要求。

我对任何拼写或语法错误表示歉意。 我来自德国，因此不是母语，所以我希望你能原谅我:)

在此先感谢您的帮助！

编辑：如果有人感兴趣：我测量了我需要一个简单的makro与代码使用范围和复制和logging集的时间。 而范围的东西花了0.26s的logging集在0.08s，这是令人难以置信的。 这是速度的3倍。

感谢您所有的帮助！ 🙂

---

我实际上尝试了一种与logging集不同的方法。 问题是我真的不能完全理解logging集，因此无法编程我现在需要的东西。 我现在的想法是以面向对象的方式来实现它。 我知道VBA很难在整个程序中继续使用它，但它使得它更容易理解。 我会给你发一个我创build的课程，但现在还不行。

 Option Explicit 'Array in dem die übergebenen Filter gespeichert werden Dim filter() 'Konstruktor Private Sub Class_Initialize() ReDim filter(0, 2) End Sub 'Prüft, ob Filter in übergebener Zeile übereinstimmt. Function IsValidLine(originalArray(), row) As Boolean Dim i As Integer IsValidLine = True 'Durchläuft Filter und vergleicht diesen mit übergebener Zeile For i = 1 To UBound(filter) 'Wenn Filter einmal nicht übereinstimmt wird Function verlassen If Not originalArray(row, filter(i, 1)) = filter(i, 2) Then IsValidLine = False Exit Function End If Next i End Function 'Kopiert die übergebene Zeile des ungefilterten Arrays in das Gefilterte Sub CopyLine(Zeile As Integer, originalArray, ByRef newArray) Dim i As Integer 'Gefiltertes Array wird um eine Zeile erweitert ReDim newArray(1 To UBound(newArray) + 1, 1 To UBound(originalArray, 2)) 'Kopieren For i = 1 To UBound(originalArray, 2) newArray(UBound(newArray), i) = originalArray(Zeile, i) Next i End Sub 'Function, um Filter zur Klasse hinzuzufügen Sub Add(Spalte As Integer, Kriterium) 'Filterarray wird um eine Zeile erweitert und Spalte und Kriterium 'des neuen Filters werden in diese eingetragen ReDim filter(1 To UBound(filter) + 1, 1 To 2) filter(UBound(filter), 1) = Spalte filter(UBound(filter), 2) = Kriterium End Sub 'Aktueller Filter wird angewendet um das übergebene Array mit diesem zu 'Filtern und ein neues, gefiltertes Array zurückzugeben Function getFilteredArray(originalArray()) Dim i As Integer, j As Integer Dim newArray() ReDim newArray(1 To 1, 1 To UBound(originalArray, 2)) 'Durchläuft alle Zeilen des übergebenen Arrays For i = 1 To UBound(originalArray, 1) 'Wenn eine Zeile mit dem Filter übereinstimmt wird sie in das 'gefilterte Array übernommen If IsValidLine(originalArray, i) Then 'Zeile, die übereingestimmt hat, wird kopiert CopyLine i, originalArray, newArray End If Next i 'NewArray als gefiltertes Array zurückgeben getFilteredArray = newArray End Function 

没有语法错误，这是合乎逻辑的。 那么我们的目标是从“getFilteredArray”中得到一个类似于使用自动filter的数组。

感谢您的所有意见，请不要以为我不欣赏logging集，但我没有时间深入研究它。 据我从一些文章和博客中读到的logging集通常用于访问？ 而对我来说很难的事情就是没有智慧，当我完全陌生时，大部分时间都会帮助我。

此刻getFilteredArray方法给了我一个606行的数组（这是正确的），但只有最后一个有值。 所有其他的都是空的。 我不确定问题是什么，所以问题是：P

Answer 1

考虑使用logging集而不是multidimensional array。 这里显示了在Excel中使用它们的最简单的方法。

一世。 添加这个function

 Function GetRecordset(rng As Range) As Object 'Recordset ohne Connection: 'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/ Dim xlXML As Object Dim rst As Object Set rst = CreateObject("ADODB.Recordset") Set xlXML = CreateObject("MSXML2.DOMDocument") xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML) rst.Open xlXML Set GetRecordset = rst End Function 

II。 下面应该给你一个如何使用数据操作的logging集的想法

 Sub testrecordset() Dim rs As Object Set rs = GetRecordset(ThisWorkbook.Sheets(1).UsedRange) With rs Debug.Print .RecordCount ' how to set a filter .Filter = "FirstName = 'Henry'" Debug.Print .RecordCount ' how to remove a filter .Filter = vbNullString ' how to output headers Dim i As Integer: i = 1 Dim fld As Object For Each fld In .Fields ThisWorkbook.Sheets(2).Cells(1, i).Value = fld.Name i = i + 1 Next fld ' how to output filtered data ThisWorkbook.Sheets(2).Cells(2, 1).CopyFromRecordset rs ' how to loop individual records and access individual fields While Not .EOF Debug.Print !FirstName & vbTab & !IntValue .MoveNext Wend End With End Sub 

注意：

• 如果你想循环循环logging集（例如你设置了一个filter，循环所有logging，设置另一个filter，再次循环所有logging），你必须在.MoveFirst再次循环之前，所以你的下一个循环再次从第一个logging开始

• 因为这可能有点令人生畏你第一次设置它，我build议你发布FilterAnlegen的代码，我们从那里继续

• 如果在实际的标题行上面有任何行，那么在确定rng.Value(xlRangeValueMSPersistXML)正确的标题时，Excel可能会遇到问题， 正如我在这里描述的那样 ，两行而不是仅使用一行（例如，字段名称带有前导空格空行）。 可能的修复：

  a）从Row(1)开始

  b）在将XML传递给DOMDocument xlXML.LoadXML Replace(rng.Value(xlRangeValueMSPersistXML), "rs:name="" ", "rs:name=""")之前，replaceXML中的空格

  c）在代码中引用Field.Name时包含空格

Answer 2

你的问题不够具体。

如果你想要一般的VBA加快技巧 – 在这里阅读我的文章。

我想你可能会对Excel中的QueryTables（Excel中的 SQL）感兴趣，以便能够在多个工作表或多列上运行筛选 – 请参阅我的教程 。

否则，你需要向我们展示一个更精确的加速技巧的具体程序。