Excel VBA中的动态数据结构

目前，我正在努力提高VBA程序的性能，因为执行某些表操作需要很长时间

在程序运行期间，我尝试将数据存储在工作表中，但写入操作将永远持续，我希望动态存储此数据，而不是将其写入工作表中，以减少运行所需的时间

我曾考虑使用数组而不是工作表来存储数据，但我不确定这是否可行，因为我不知道我的表到底有多少行/列

这里是我的代码，任何帮助都是感激的

Public row As Long
Public rowMax As Long
Public startRow As Integer
Public materialType As String
Public filter As String
Public col As Integer
Public colMax As Integer
Public isUsed As Boolean
Public a As Integer

Sub bestimmeObFelderGenutzt()
    Debug.Print ("bestimmeObFelderGenutzt:begin" & " " & Now())
    With Sheets("Sheet1")
        filter = "I"
        startRow = 2
        rowMax = Sheets("Sheet1").Cells(.Rows.Count, "F").End(xlUp).row
        colMax = Sheets("Sheet1").Cells(1, .Columns.Count).End(xlToLeft).Column
        materialType = Sheets("Sheet1").Range(filter & startRow).Value

        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets.Add(After:= _
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = "Nutzung"

        For col = 1 To colMax
            Sheets("Nutzung").Cells(1, col + 2).Value = Sheets("Sheet1").Cells(1, col).Value
        Next col

        For row = 2 To rowMax
            Sheets("Nutzung").Range("A" & row).Value = Sheets("Sheet1").Range("A" & row).Value
            Sheets("Nutzung").Range("B" & row).Value = Sheets("Sheet1").Range("I" & row).Value
                For col = 1 To colMax
                    If IsEmpty(Sheets("Sheet1").Cells(row, col)) = False Then
                        isUsed = True
                        Sheets("Nutzung").Cells(row, col + 2).Value = 1
                    Else:
                        Sheets("Nutzung").Cells(row, col + 2).Value = 0
                    End If
                Next col
        Next row
    End With
    Debug.Print ("bestimmeObFelderGenutzt:end" & " " & Now())
End Sub



Sub findeUngenutzteSpalten(ByVal materialType As String, pos As Integer)
    Debug.Print ("findeUngenutzteSpalten:begin" & " " & materialType & " " & Now())
    With Sheets(materialType)
        rowMax = Sheets(materialType).Cells(.Rows.Count, "F").End(xlUp).row
        colMax = Sheets(materialType).Cells(1, .Columns.Count).End(xlToLeft).Column

        Sheets("Auswertung").Cells(1, 1).Value = "Spaltenüberschrift:"
        Dim a As Integer
        For a = 1 To colMax
            Sheets("Auswertung").Cells(a + 1, 1).Value = Sheets("Sheet1").Cells(1, a).Value
        Next a

        Sheets("Auswertung").Cells(1, pos + 1).Value = materialType

        For col = 3 To colMax
            For row = 2 To rowMax
                    If Sheets(materialType).Cells(row, col).Value = 1 Then
                        Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Ja"
                        GoTo WeiterCol
                    Else:
                        If row = rowMax Then
                            Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Nein"
                        Else:
                            GoTo WeiterRow
                        End If
                    End If
WeiterRow:
            Next row
WeiterCol:
        Next col
    End With
    Debug.Print ("findeUngenutzteSpalten:end" & " " & materialType & " " & Now())
End Sub

Sub kopiereZeilen(ByVal materialType As String)
    Debug.Print ("kopiereZeilen:begin" & " " & materialType & " " & Now())
    With Sheets("Nutzung")
        rowMax = Sheets("Nutzung").Cells(.Rows.Count, "F").End(xlUp).row

        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets.Add(After:= _
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = materialType

        Sheets("Nutzung").Cells(1, 1).EntireRow.Copy Sheets(materialType).Cells(1, 1)
        Dim unusedRow As Long

        For row = 2 To rowMax
            unusedRow = Sheets(materialType).Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).row
            If Sheets("Nutzung").Cells(row, 2).Value = materialType Then
                Sheets("Nutzung").Cells(row, 2).EntireRow.Copy Sheets(materialType).Cells(unusedRow, 1)
            End If
        Next row
    End With
    Debug.Print ("kopiereZeilen:end" & " " & materialType & " " & Now())
End Sub

Sub allesZusammen()

    Debug.Print ("Hauptaufruf:begin" & " " & Now())

    Dim types(10) As String
    Dim element As Variant
    Dim pos As Integer

    bestimmeObFelderGenutzt

    types(0) = "A"
    types(1) = "B"
    types(2) = "C"
    types(3) = "D"
    types(4) = "E"
    types(5) = "F"
    types(6) = "G"
    types(7) = "H"
    types(8) = "I"
    types(9) = "J"
    types(10) = "K"

    Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets.Add(After:= _
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = "Auswertung"

    For Each element In types
        kopiereZeilen (element)
        pos = Application.Match(element, types, False)
        findeUngenutzteSpalten element, pos
    Next element
    Debug.Print ("Hauptaufruf:end" & " " & Now())

End Sub

---

您可以声明动态数组。一般语法为：

Dim Values() As Long

要使用该数组，必须首先将其重新标注为所需的大小。例如，这声明了一个基于零的3 x 5值的二维数组：

ReDim Values(2, 4)

如果要根据变量调整大小，请使用以下方法：

ReDim Values(myrowsize, mycolumnsize)

您可以使用以下语法动态增长或收缩阵列：

ReDim Preserve Values(2, mynewsize)

请注意，您只能重新标注数组的最后一个索引。所以这是不允许的：

ReDim Preserve Values(mynewsize, 4)

但这在您的情况下可能是可以的，因为您有固定数量的列

将动态数组声明为UDT完全可以。例如：

Type UDTInfo
    valueA As Long
    valueB As Long
End Type

Sub test()
    Dim Values() As UDTInfo

    ReDim Values(2, 4)

    ReDim Preserve Values(2, 5)

End Sub

您可以按正常方式访问阵列：

x = Values(1, 2)

您可以直接将一个动态数组复制到另一个，只要维度的类型和数量与大小匹配并不重要：

Dim Values() As Integer
Dim Results() As Integer

Results = Values

最后，您可以通过以下方式在函数之间传递动态数组：

Function SomeFunc(ByRef Values() As Long) As Long()
    Dim ReturnValues() As Long

    ReturnValues = Values

    SomeFunc = ReturnValues
End Function

---

注意，只传递动态数组ByRef，不传递ByVal。

尝试使用Application.ScreenUpdate方法。查看excel帮助使用。是的，这帮助了很多，现在程序运行速度快了29%！但我需要更快的速度，因为即使它运行的时间减少了29%，但您仍要在每个单元格上迭代大约5个小时。首先尝试筛选条件，然后将范围作为一个整体复制。或者使用数据库。很乐意帮忙。希望能快得多。是的，感觉就像时间旅行：D