VBA加速代码 [英] VBA Speeding up Code

问题描述

从假期回来后，我发现自己非常有动力加快我去年编写的VBA代码.基本数据是公司已采取或想要采取的措施的清单.我的工作是创建一个宏，以使某些员工更容易从非常不满意的列表中获取某些信息.

Coming back from the holidays I find myself quite motivated to speed up the VBA Code I wrote last year. The basic data is a list of measures the company did or wants to do. My job was to create a macro to make it easier for some of the employees to get certain information out of the very uncomfortable list.

起初，我对VBA还是很陌生，但是很快就学会了基础知识.现在的问题是，某些过程花费的时间太长.在大多数情况下，实际上在整个程序中，我都会使用一些我知道会使宏变慢的东西，但是，这就是我需要您帮助的地方，我只是不知道如何做得更好.

In the beginning I was quite new to VBA but learned the basics quite fast. The Problem now is, that some of the procedures take too long. Most of the time, actually throughout the whole program, I use some things that I know are making the macro slower but, that's where I will need your help, I just dont know how to make better.

例如:

有一个UserForm，它应该提供一种导出过滤列表的简单方法.到现在为止，我让员工选择他要过滤的内容，然后使用自动过滤器过滤列表，然后将可见的单元格复制到另一个工作表中.显然，我使用了诸如autofilter之类的东西，这些东西使宏比例如使用数组要慢得多.

There is a UserForm which is supposed to provide a simple way to export a filtered list. Til now I'm letting the employee choose what he wants to filter, then I filter the list by using the autofilter and proceed by copying the visible cells to another Worksheet. Obviously I use some things like the autofilter that make a macro severely slower than using arrays for example.

一些示例代码.这有点困难，因为我使用了许多模块和函数，因为这是一个很大的项目，但我将尝试向您展示.我希望您理解它，因为名称和变量显然是德语.

Some example code. It's kinda hard because I'm using many moduls and functions because it's quite a big project but I'll try to show you. I hope you understand it because the names and variables are german obviously.

这就是我调用该函数的代码，该函数使用自动过滤器过滤我正在谈论的Excel工作表.

Thats the Code where I call the function that uses autofilter to filter the Excel sheet I was talking about.

'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:

Here the 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工作表，因此我需要一个多维数组.这比一维的慢吗?

My question is basically wheather arrays would be the best solution for this and how you would solve this. But some other questions are coming along with this. Since this is a Excel sheet over multiple columns I would need a multidimensional array. Is this slower than a one dimensional one?

如果您不了解任何内容，或者需要澄清一些事情，只需提出要求.

If there is anything you don't understand or some things I need to clarify just ask for it.

对于任何拼写或语法错误，我深表歉意.我来自德国，因此不是母语人士，所以希望您能原谅我:)

I apologize for any spelling or grammar mistakes. I'm from germany thus not a native speaker so I'm hoping you can forgive me :)

在此先感谢您的帮助！

如果有人感兴趣:我用一个使用范围和复制以及记录集的代码测量了一个简单的makro所需的时间.虽然范围的东西用了0.26秒，但记录集却用了0.08秒，这是令人难以置信的.那就是速度的三倍.

If someone is interested: I measured the time I needed for a simple makro with a code that uses ranges and copying and the recordset. While the range stuff took 0,26s the recordset made it in 0,08s which is incredible. Thats 3 times the speed.

感谢您的所有帮助！:)

Thanks for all of your help! :)

实际上，我现在尝试了一种与记录集完全不同的方法.问题是我真的不能完全理解记录集，因此无法对我目前需要的东西进行编程.我现在的想法是以一种面向对象的方式来实现它.我知道在VBA中很难使其在整个程序中持续进行，但是它使它变得更容易理解.我将向您发布我创建的课程，但遗憾的是该课程无法正常工作.

I actually tried a very different approach now than the recordset. The problem is that I'm really not understanding the recordset completely and therefore can't program the things I need at the moment. My Idea now was to approach it in a object orientated way. I know its hard in VBA to keep it going throughout the program but it just makes it so much easier to understand. I'll post you a class I created which is sadly not working yet.

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"中获取一个数组，这与我使用自动过滤器所得到的相似.

There are no syntax mistakes it's all logical. Well the goal is to get an array out of the "getFilteredArray" thats similar to what I would get from using the autofilter.

感谢您的所有输入，请不要以为我不欣赏记录集的内容，但是我没有时间深入研究atm.据我从一些文章和博客中读到的记录集通常用于访问?而且对我来说也很困难的是，没有智能，当我完全陌生时，在大多数情况下都会对我有帮助.

Thanks for all of your input and please don't think I'm not appreciating the recordset stuff but I just dont have the time to look deeper into it atm. As far as I read it from some articles and blogs the recordset is usually used in access? and what makes it hard for me aswell is that there is not intellisense and when I am completely new to something it helps me a lot most of the times.

目前，getFilteredArray方法为我提供了一个具有606行的数组(这是正确的)，但只有最后一个具有值.其他所有的都是空的.我不确定是什么问题，所以问题:P

At the moment the getFilteredArray method gives me an array with 606 lines (which is correct) but only the last one has values. all other ones are empty. I'm not sure what the problem is hence the question :P

推荐答案

考虑使用记录集而不是多维数组.我是

Consider using a recordset instead of multidimensional arrays. The i.m.o. easiest way of using them in Excel is shown here.

i.添加此功能

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.下面应该使您了解如何使用记录集进行数据操作

ii. the following should give you an idea of how to use recordsets for data operations

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 ，因此您的下一个循环再次从第一条记录开始

• if you want to loop the recordset repeadedly (e.g. you set a filter, loop all records, set another filter, loop all records again), you have to .MoveFirst before looping again, so your next loop starts at the first record again

因为这是您首次设置时可能会有些畏缩，所以我建议您发布 FilterAnlegen 的代码，然后从那里继续

since this can be a bit daunting the first time you set it up, i suggest you post the code of FilterAnlegen and we go on from there

如果实际标题行上方有任何行，则在确定 rng.Value(xlRangeValueMSPersistXML)中的正确标题时，Excel可能会遇到麻烦

if there are any rows above your actual header row, Excel can have trouble when determining the correct headers in rng.Value(xlRangeValueMSPersistXML) as I described here, concatinating two rows instead of just using one row (e.g. field names have leading blanks with an empty row). Possible fixes:

a)从 Row(1)

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

b) replacing blanks in the XML before passing it to the DOMDocument xlXML.LoadXML Replace(rng.Value(xlRangeValueMSPersistXML), "rs:name="" ", "rs:name=""")

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

c) include the blanks when referencing Field.Name in code

这篇关于VBA加速代码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！