VBA Excel For循环与变体数组崩溃Excel答案

【问题标题】：VBA Excel For loop with Variant Arrays crashing ExcelVBA Excel For循环与变体数组崩溃Excel
【发布时间】：2017-12-01 02:44:44
【问题描述】：

下午。我正在使用 For/Next 循环和 ReDim Preserve 向变体数组添加和未确定数量的值（客户）。我的代码如下：

lRow = sht1.Cells(sht1.Rows.Count, 1).End(xlUp).Row
cCount = 0
uCount = 0

var_Events = sht1.Range("A2:BC" & lRow).Value2

For i = LBound(var_Events) To UBound(var_Events)

    ReDim Preserve var_Customers(0 To cCount)

    If Not CustInArray(str(var_Events(i, 2)), var_Customers) Then

        var_Customers(cCount) = str(var_Events(i, 2))
        cCount = cCount + 1

    End If

    If i Mod 100 = 0 Then

        MsgBox "Line: " & i

    End If

Next i

这里是 CustInArray 函数：`

Function CustInArray(str As String, arr As Variant) As Boolean

    CustInArray = (UBound(Filter(arr, str)) > -1)

End Function`

我在第一次崩溃后添加了 Mod/MsgBox，以查看它在哪里/何时崩溃且没有错误。在 excel 崩溃之前它到达了大约 6000 行（我没有看到“Line: 6000” MsgBox）。

我检查了 var_Events 的 UBound，它是 6290，与我的 WS 上的行数一致。我也尝试过 (UBound(var_Events) - 1)，但仍然没有运气。

我不是 100% 为什么它会崩溃，因为没有错误，所以这就是我现在所能提供的。提前致谢！

编辑：我在 cmets 中提到了这一点，但认为在这里添加会很好。我最初想使用字典，但这只是较长过程的第一部分。每个客户都会有未知数量的项目分配给他们，并且这些项目的类别数量未知。

【问题讨论】：

Redim Preserve 数组数千次非常消耗资源并且可能耗尽内存。我敦促您开始使用Dictionary Object。
内存没有用完，你提到后我查了。永远不要使用超过 500MB（可用的 26GB）。我最初想使用字典，但这只是较长过程的第一部分。每个客户都会有未知数量的项目分配给他们，并且这些项目的类别数量未知。
当您说Crashes 时，它究竟做了什么？ excel会关闭并消失吗？有错误吗？或者它会冻结并变白？
您可能有兴趣阅读this。 “32 位版本的 Excel 似乎对 VBA（数组、代码等）有大约 500MB 的内存限制。”。 不要假设 VBA 会有效地利用您系统上的所有可用内存。它有固有的局限性。此外，我不明白为什么字典不能满足您提到的这些要求。
说真的，一个一个地重新调整数组是一个非常糟糕的设计选择。至少，一次分配最大可能的大小，然后在最后截断数组。但还是很糟糕。字典是一种可能的选择，但不是唯一的。

标签： vba excel for-loop variant

【解决方案1】：

从足够大的数组开始，以容纳每一行的值，然后在末尾使用ReDim Preserve 将其缩小到正确的大小：

lRow = sht1.Cells(sht1.Rows.Count, 1).End(xlUp).Row
ReDim var_customers(0 to lRow - 1)
cCount = 0
uCount = 0

var_Events = sht1.Range("A2:BC" & lRow).Value2

For i = LBound(var_Events) To UBound(var_Events)
    If Not CustInArray(str(var_Events(i, 2)), var_Customers) Then
        var_Customers(cCount) = str(var_Events(i, 2))
        cCount = cCount + 1
    End If

    If i Mod 100 = 0 Then
        MsgBox "Line: " & i
    End If
Next i

ReDim Preserve var_customers(0 to cCount)

有更好的方法来做到这一点，但是，一个 Dictionary 对象（如 cmets 中所指出的），内置的“删除重复”命令，或使用 ADO - 像这样：

' Set up connection
Dim cn As Object
Set cn = CreateObject("ADODB.Connection")

' Connection string for Excel 2007 onwards .xlsm files
With cn
   .Provider = "Microsoft.ACE.OLEDB.12.0"
   .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
        "Extended Properties=""Excel 12.0 Macro;IMEX=1"";"
    .Open
End With

' Connection string for Excel 97-2003 .xls files
' It should also work with Excel 2007 onwards worksheets
' as long as they have less than 65536 rows
'With cn
'    .Provider = "Microsoft.Jet.OLEDB.4.0"
'    .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
'        "Extended Properties=""Excel 8.0;IMEX=1"";"
'    .Open
'End With

' Create and run the query
Dim rs As Object
Set rs = CreateObject("ADODB.Recordset")

' Get all unique customers - assumes worksheet is named "Sheet1"
' and column name in cell B1 is "Customer"
rs.Open "SELECT DISTINCT [Customer] FROM [Sheet1$];", cn

' Output the field names and the results
Dim fld As Object
Dim i As Integer

' Change the worksheet to whichever one you want to output to
With Worksheets("Sheet3")
    .UsedRange.ClearContents

    For Each fld In rs.Fields
        i = i + 1
        .Cells(1, i).Value = fld.Name
    Next fld

    .Cells(2, 1).CopyFromRecordset rs

    ' You could now read the range values back into a variant array if you wanted to
End With

' Tidy up
rs.Close
cn.Close

【讨论】：