VBA Excel For循环与变种arrays崩溃的Excel
所有的下午。 我正在使用For / Next循环和ReDim保留将数量（客户）的值添加到不确定的数组中。 我的代码如下：
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％，为什么它会崩溃，因为没有错误，所以这就是我现在可以提供的。 提前致谢！
编辑：我在评论中提到这一点，但认为这将是很好的补充。 我最初以为使用字典，但这只是一个较长的过程的第一部分。 每个客户将有一个未知数量的项目分配给他们，和这些项目的类别数量未知。
从数组大到足以容纳每一行的值，然后使用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对象（如注释中指出的那样），内置的“Remove Duplicates”命令，或者使用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