Question

从假期回来后，我发现自己很有动力去加速我去年写的VBA代码。基本数据是公司做或想做的措施清单。我的工作是创建一个宏，以便让一些员工更容易从非常不舒服的列表中获取某些信息。

一开始我对VBA很新，但很快学会了基础知识。现在的问题是，某些程序需要太长时间。大多数情况下，实际上在整个程序中，我使用了一些我知道使宏变慢的东西但是，我需要你的帮助，我只是不知道如何做得更好。

例如：

有一个UserForm应该提供一种导出过滤列表的简单方法。现在，我让员工选择他想要过滤的内容，然后使用自动过滤器过滤列表，然后将可见单元格复制到另一个工作表。显然，我使用像autofilter这样的东西会使宏比使用数组慢得多。

编辑：一些示例代码。这很难，因为我使用了许多模块和功能，因为它是一个相当大的项目，但我会试着告诉你。我希望你理解它，因为名字和变量显然是德语。

这就是我调用使用自动过滤功能来过滤我正在谈论的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

这里是Function 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

我的问题基本上是天使阵列是最好的解决方案，以及如何解决这个问题。但是其他一些问题也随之而来。由于这是多列上的Excel工作表，我需要一个多维数组。这比一维的慢吗？

如果有任何你不理解的东西，或者我需要澄清的一些事情只是要求它。

我为任何拼写错误或语法错误道歉。我来自德国，因此不是母语，所以我希望你能原谅我：）

提前感谢您的帮助！

编辑：如果有人感兴趣：我测量了一个简单的makro所需的时间，其代码使用范围和复制以及记录集。虽然该系列音频占用了0.26秒，但它的音量设定为0,08秒，令人难以置信。这是速度的3倍。

感谢您的帮助！：）

我实际上尝试了一种与记录集完全不同的方法。问题是我真的不完全理解记录集，因此无法对我目前需要的东西进行编程。我的想法现在是以面向对象的方式接近它。我知道VBA很难在整个程序中继续运行，但它只是让它更容易理解。我会给你发一个我创建的课程，遗憾的是还没有工作。

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

没有语法错误，它都是合乎逻辑的。那么我们的目标是从＆＃34; getFilteredArray＆＃34;中获取数组。这与我使用自动过滤器得到的相似。

感谢您的所有投入，请不要以为我不欣赏记录集的内容，但我没有时间深入了解它。据我从一些文章和博客中读到的那样，记录集通常用于访问？而且对我来说难以理解的是，没有智能感，当我对某些东西完全陌生时，它在很多时候都会帮助我很多。

目前，getFilteredArray方法为我提供了一个包含606行的数组（这是正确的），但只有最后一行有值。所有其他的都是空的。我不确定问题是什么因此问题：P

Answer 1

你的问题不够具体。

如果您想要一般VBA Speed up tips - read my article here.

我认为您可能对Excel中的 QueryTables （Excel中的SQL）感兴趣，以便能够在多个工作表或多列上运行过滤 - see my tutorial here。

否则，您需要向我们展示一个特定的程序，以获得更精确的加速提示。

Answer 2

考虑使用记录集而不是多维数组。 i.m.o.在Excel中使用它们的最简单方法是显示here。

我。添加此功能

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。以下内容应该让您了解如何使用记录集进行数据操作

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

注意：

如果你想要循环循环记录集（例如你设置一个过滤器，循环所有记录，设置另一个过滤器，再次循环所有记录），你必须在再次循环之前.MoveFirst，所以你的下一个循环再次从第一个记录开始

因为第一次设置时这可能有点令人生畏，我建议您发布FilterAnlegen的代码，我们会从那里继续

如果您的实际标题行上方有任何行，则在rng.Value(xlRangeValueMSPersistXML) as I described here中确定正确的标题时，Excel可能会遇到问题，而不是仅使用一行（例如字段）名称具有空行的前导空格）。可能的修复：

a）从Row(1)
开始
b）在将XML传递给DOMDocument xlXML.LoadXML Replace(rng.Value(xlRangeValueMSPersistXML), "rs:name="" ", "rs:name=""")
之前替换XML中的空格
c）在代码

中引用Field.Name时包含空格

VBA加速代码

2 个答案: