VBA Excel 变体数组崩溃的 For 循环 Excel
VBA Excel For loop with Variant Arrays crashing Excel
下午好。我正在使用 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 第一次崩溃后添加了它,看到 where/when 它没有错误地崩溃了。在 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)
但是,有更好的方法可以做到这一点,字典对象(如注释中所指出的),内置 "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
下午好。我正在使用 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 第一次崩溃后添加了它,看到 where/when 它没有错误地崩溃了。在 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)
但是,有更好的方法可以做到这一点,字典对象(如注释中所指出的),内置 "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