VBA 动态数组错误地复制了一些值
VBA dynamic array duplicating some values in error
首先我想说我完全不知道为什么我的代码正在做它正在做的事情。我真的希望这里的一位 VBA 专家能提供帮助。另外，这是我的第一个post，所以我尽力遵守规则，但如果我做错了什么，请指出。
我有一个子程序，它遍历一列数据并创建一个数组。它调用一个函数来检查特定值是否已经在数组中。如果不是，则重新确定数组的尺寸，插入值，然后重新开始该过程，一直持续到到达列表末尾。我最终得到一个总计 41 个值的数组，但其中 4 个已被复制两次，因此数组中只有 37 个唯一值。
我一辈子都弄不明白是什么让这些价值观与众不同，或者为什么它们会被重复。总列表有 700 多个值，所以我想我应该看到其他值重复，但我没有。
下面是创建数组的子代码：
Sub ProductNumberArray(strWrkShtName As String, strFindColumn As String, blAsGrp As Boolean, iStart As Integer)
Dim i As Integer
Dim lastRow As Integer
Dim iFindColumn As Integer
Dim checkString As String
With wbCurrent.Worksheets(strWrkShtName)
iFindColumn = .UsedRange.Find(strFindColumn, .Range("A1"), xlValues, xlWhole, xlByColumns).Column
lastRow = .Cells(Rows.Count, iFindColumn).End(xlUp).row
For i = iStart To lastRow
checkString = .Cells(i, iFindColumn).Value
If IsInArray(checkString, arrProductNumber) = False Then
If blAsGrp = False Then
ReDim Preserve arrProductNumber(0 To j)
arrProductNumber(j) = checkString
j = j + 1
Else
ReDim Preserve arrProductNumber(1, 0 To j)
arrProductNumber(0, j) = .Cells(i, iFindColumn - 1).Value
arrProductNumber(1, j) = checkString
j = j + 1
End If
End If
Next i
End With
End Sub
下面是检查 checkString 值是否在数组中的代码：
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
我们非常欢迎任何帮助。我以前能够找到我所有问题的答案（或者至少调试并看到一个明显的问题）但是这个问题难倒了我。我希望有人能弄清楚这是怎么回事。
[编辑] 这是调用 sub 的代码：
Sub UpdatePSI()
Set wbCurrent = Application.ActiveWorkbook
Set wsCurrent = wbCurrent.ActiveSheet
frmWorkbookSelect.Show
If blFrmClose = True Then 'if the user closes the selection form, the sub is exited
blFrmClose = False
Exit Sub
End If
Set wsSelect = wbSelect.Sheets(1)
Call ProductNumberArray("Forecast", "Item", True, 3)
wbCurrent、wsCurrent 和 blFrmClose 在一般声明中定义。
问题
您正在检查变量数组中的字符串。数据可以是字符串或数字，因此会重复。我建议将函数 Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 更改为 Function IsInArray(stringToBeFound As Variant, arr() As Variant) As Boolean
有几个变量需要声明。见下文。
Sub ProductNumberArray(strWrkShtName As String, strFindColumn As String, blAsGrp As Boolean, iStart As Integer)
Dim i As long, j as long 'just use long for i. integers are silently converted to long anyway. leaving j undeclared makes it variant.
Dim lastRow As Integer
Dim iFindColumn As Integer
Dim checkString As Variant ' changed to variant
Dim arrProductNumber() as Variant ' delcare a dynamic array
ReDim arrProductNumber(0 To 0) ' making it an array
j = 0 'giving somewhere to start
With wbCurrent.Worksheets(strWrkShtName)
iFindColumn = .UsedRange.Find(strFindColumn, .Range("A1"), xlValues, xlWhole, xlByColumns).Column
lastRow = .Cells(Rows.Count, iFindColumn).End(xlUp).row
For i = iStart To lastRow
checkString = .Cells(i, iFindColumn).Value
If IsInArray(checkString, arrProductNumber) = False Then
If blAsGrp = False Then
ReDim Preserve arrProductNumber(0 To j)
arrProductNumber(j) = checkString
j = j + 1
Else
ReDim Preserve arrProductNumber(1, 0 To j)
arrProductNumber(0, j) = .Cells(i, iFindColumn - 1).Value
arrProductNumber(1, j) = checkString
j = j + 1
End If
End If
Next i
End With
End Sub
我猜你得到了重复项，因为 j 和 arrProductNumber 是全局变量。您应该通过将工作表传递给将 return 您的数组的函数来摆脱全局变量。
您只需将单元格引用添加到 Scripting.Dictionary
If not dic.Exists(Cell.Value) then dic.Add Cell.Value, Cell
然后通过它的键值检索引用
ProductOffset = dic("PID798YD").Offset(0,-1)
我在这里使用 ArrayList（我本可以使用 Scripting.Dictionary）来检查重复项并作为 Redim 多维数组的计数器。
Sub TestgetProductData()
Dim results As Variant
results = getProductData(ActiveSheet, "Column 5", True, 3)
Stop
results = getProductData(ActiveSheet, "Column 5", False, 3)
Stop
End Sub
Function getProductData(ws As Worksheet, ColumnHeader As String, blAsGrp As Boolean, iStart As Integer) As Variant
Dim results As Variant
Dim cell As Range, Source As Range
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With ws.UsedRange
Set Source = .Find(ColumnHeader, .Range("A1"), xlValues, xlWhole, xlByColumns)
If Not Source Is Nothing Then
Set Source = Intersect(.Cells, Source.EntireColumn)
Set Source = Intersect(.Cells, Source.Offset(iStart))
For Each cell In Source
If Not list.Contains(cell.Value) Then
If blAsGrp Then
If list.Count = 0 Then ReDim results(0 To 1, 0 To 0)
ReDim Preserve results(0 To 1, 0 To list.Count)
results(0, list.Count) = cell.Offset.Value
results(1, list.Count) = cell.Value
End If
list.Add cell.Value
End If
Next
End If
End With
If blAsGrp Then
getProductData = results
Else
getProductData = list.ToArray
End If
End Function
根据@RonRosenfield 和@braX 的建议，我尝试了 Scripting.Dictionary 并得出了这个答案。它既创建又检查值，这与我以前使用子创建和检查函数的方法不同。
Sub ProductNumberDictionary(strWrkShtName As String, strFindCol As String, blAsGrp As Boolean, iStart As Integer)
Dim i As Integer
Dim iLastRow As Integer
Dim iFindCol As Integer
Dim strCheck As String
Set dictProductNumber = CreateObject("Scripting.Dictionary")
With wbCurrent.Worksheets(strWrkShtName)
iFindCol = .UsedRange.Find(strFindCol, .Cells(1, 1), xlValues, xlWhole, xlByColumns).Column
iLastRow = .Cells(Rows.Count, iFindCol).End(xlUp).row
For i = iStart To iLastRow
strCheck = .Cells(i, iFindCol).Value
If dictProductNumber.exists(strCheck) = False Then
If blAsGrp = False Then
dictProductNumber.Add Key:=strCheck
Else
dictProductNumber.Add Key:=strCheck, Item:=.Cells(i, iFindCol - 1).Value
End If
End If
Next
End With
End Sub
我在从这本字典中获取值时遇到了一些困难，但发现这行得通：
Dim o as Variant
i = 0
For Each o In dictProductNumber.Keys
.Cells(iRowStart + i, iFirstCol + 1) = o 'returns the value of the key
.Cells(iRowStart + i, iFirstCol + 2) = dictProductNumber(o) 'returns the item stored with the key
i = i + 1
Next
None 关于导致您遇到的重复问题的（疯狂）猜测甚至接近。它实际上是由您的代码中的错误引起的。
在您的 IsInArray 函数中，您以错误的值完成了数组循环索引。 For i = 1 To UBound(arr, 2) 应该是 For i = 1 To UBound(arr, 2) - LBound(arr, 2) + 1。当您的索引完成一个短时，这意味着永远不会针对最后一个数组项检查比较字符串，因此，任何连续相同值中的第二个将作为副本复制。始终在索引参数中同时使用 LBound 和 UBound 以避免此类错误和类似类型的错误。
但是，此修复是多余的，因为可以重写函数以避免完全循环。我还添加了一些其他增强功能：
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim bDimen As Long
Dim i As Long
On Error Resume Next
bDimen = 2
If IsError(UBound(arr, 2)) Then bDimen = bDimen - 1
If IsError(UBound(arr, 1)) Then bDimen = bDimen - 1
On Error GoTo 0
Select Case bDimen
Case 0:
' Uninitialized array - return false
Case 1:
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2:
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, 2), 0)
On Error GoTo 0
Case Else
' Err.Raise vbObjectError + 666, Description:="Never gets here error."
End Select
End Function
这是我对字典解决方案的看法：
Public Function ProductNumberDict _
( _
ByVal TheWorksheet As Worksheet, _
ByVal Header As String, _
ByVal AsGroup As Boolean, _
ByVal Start As Long _
) _
As Scripting.Dictionary
Set ProductNumberDict = New Scripting.Dictionary
With TheWorksheet.Rows(1).Cells(WorksheetFunction.Match(Header, TheWorksheet.Rows(1), 0)).EntireColumn
Dim rngData As Range
Set rngData = TheWorksheet.Range(.Cells(Start), .Cells(Rows.Count).End(xlUp))
End With
Dim rngCell As Range
For Each rngCell In rngData
With rngCell
If Not ProductNumberDict.Exists(.Value2) Then
ProductNumberDict.Add .Value2, IIf(AsGroup, .Offset(, -1).Value2, vbNullString)
End If
End With
Next rngCell
End Function
调用函数的方法如下：
Sub UpdatePSI()
Dim wkstForecast As Worksheet
Set wkstForecast = ActiveWorkbook.Worksheets("Forecast")
' ...
Dim dictProductNumbers As Scripting.Dictionary
Set dictProductNumbers = ProductNumberDict(wkstForecast, "Item", False, 7)
Set dictProductNumbers = ProductNumberDict(wkstForecast, "Item", True, 3)
Dim iRowStart As Long: iRowStart = 2
Dim iFirstCol As Long: iFirstCol = 5
With wkstForecast.Cells(iRowStart, iFirstCol).Resize(RowSize:=dictProductNumbers.Count)
.Offset(ColumnOffset:=1).Value = WorksheetFunction.Transpose(dictProductNumbers.Keys)
.Offset(ColumnOffset:=2).Value = WorksheetFunction.Transpose(dictProductNumbers.Items)
End With
' ...
End Sub
特别注意用于将字典内容复制到工作表的非循环方法。
首先我想说我完全不知道为什么我的代码正在做它正在做的事情。我真的希望这里的一位 VBA 专家能提供帮助。另外，这是我的第一个post，所以我尽力遵守规则，但如果我做错了什么，请指出。
我有一个子程序，它遍历一列数据并创建一个数组。它调用一个函数来检查特定值是否已经在数组中。如果不是，则重新确定数组的尺寸，插入值，然后重新开始该过程，一直持续到到达列表末尾。我最终得到一个总计 41 个值的数组，但其中 4 个已被复制两次，因此数组中只有 37 个唯一值。
我一辈子都弄不明白是什么让这些价值观与众不同，或者为什么它们会被重复。总列表有 700 多个值，所以我想我应该看到其他值重复，但我没有。
下面是创建数组的子代码：
Sub ProductNumberArray(strWrkShtName As String, strFindColumn As String, blAsGrp As Boolean, iStart As Integer)
Dim i As Integer
Dim lastRow As Integer
Dim iFindColumn As Integer
Dim checkString As String
With wbCurrent.Worksheets(strWrkShtName)
iFindColumn = .UsedRange.Find(strFindColumn, .Range("A1"), xlValues, xlWhole, xlByColumns).Column
lastRow = .Cells(Rows.Count, iFindColumn).End(xlUp).row
For i = iStart To lastRow
checkString = .Cells(i, iFindColumn).Value
If IsInArray(checkString, arrProductNumber) = False Then
If blAsGrp = False Then
ReDim Preserve arrProductNumber(0 To j)
arrProductNumber(j) = checkString
j = j + 1
Else
ReDim Preserve arrProductNumber(1, 0 To j)
arrProductNumber(0, j) = .Cells(i, iFindColumn - 1).Value
arrProductNumber(1, j) = checkString
j = j + 1
End If
End If
Next i
End With
End Sub
下面是检查 checkString 值是否在数组中的代码：
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
我们非常欢迎任何帮助。我以前能够找到我所有问题的答案（或者至少调试并看到一个明显的问题）但是这个问题难倒了我。我希望有人能弄清楚这是怎么回事。
[编辑] 这是调用 sub 的代码：
Sub UpdatePSI()
Set wbCurrent = Application.ActiveWorkbook
Set wsCurrent = wbCurrent.ActiveSheet
frmWorkbookSelect.Show
If blFrmClose = True Then 'if the user closes the selection form, the sub is exited
blFrmClose = False
Exit Sub
End If
Set wsSelect = wbSelect.Sheets(1)
Call ProductNumberArray("Forecast", "Item", True, 3)
wbCurrent、wsCurrent 和 blFrmClose 在一般声明中定义。
问题
您正在检查变量数组中的字符串。数据可以是字符串或数字，因此会重复。我建议将函数 Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 更改为 Function IsInArray(stringToBeFound As Variant, arr() As Variant) As Boolean
有几个变量需要声明。见下文。
Sub ProductNumberArray(strWrkShtName As String, strFindColumn As String, blAsGrp As Boolean, iStart As Integer)
Dim i As long, j as long 'just use long for i. integers are silently converted to long anyway. leaving j undeclared makes it variant.
Dim lastRow As Integer
Dim iFindColumn As Integer
Dim checkString As Variant ' changed to variant
Dim arrProductNumber() as Variant ' delcare a dynamic array
ReDim arrProductNumber(0 To 0) ' making it an array
j = 0 'giving somewhere to start
With wbCurrent.Worksheets(strWrkShtName)
iFindColumn = .UsedRange.Find(strFindColumn, .Range("A1"), xlValues, xlWhole, xlByColumns).Column
lastRow = .Cells(Rows.Count, iFindColumn).End(xlUp).row
For i = iStart To lastRow
checkString = .Cells(i, iFindColumn).Value
If IsInArray(checkString, arrProductNumber) = False Then
If blAsGrp = False Then
ReDim Preserve arrProductNumber(0 To j)
arrProductNumber(j) = checkString
j = j + 1
Else
ReDim Preserve arrProductNumber(1, 0 To j)
arrProductNumber(0, j) = .Cells(i, iFindColumn - 1).Value
arrProductNumber(1, j) = checkString
j = j + 1
End If
End If
Next i
End With
End Sub
我猜你得到了重复项，因为 j 和 arrProductNumber 是全局变量。您应该通过将工作表传递给将 return 您的数组的函数来摆脱全局变量。
您只需将单元格引用添加到 Scripting.Dictionary
If not dic.Exists(Cell.Value) then dic.Add Cell.Value, Cell
然后通过它的键值检索引用
ProductOffset = dic("PID798YD").Offset(0,-1)
我在这里使用 ArrayList（我本可以使用 Scripting.Dictionary）来检查重复项并作为 Redim 多维数组的计数器。
Sub TestgetProductData()
Dim results As Variant
results = getProductData(ActiveSheet, "Column 5", True, 3)
Stop
results = getProductData(ActiveSheet, "Column 5", False, 3)
Stop
End Sub
Function getProductData(ws As Worksheet, ColumnHeader As String, blAsGrp As Boolean, iStart As Integer) As Variant
Dim results As Variant
Dim cell As Range, Source As Range
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With ws.UsedRange
Set Source = .Find(ColumnHeader, .Range("A1"), xlValues, xlWhole, xlByColumns)
If Not Source Is Nothing Then
Set Source = Intersect(.Cells, Source.EntireColumn)
Set Source = Intersect(.Cells, Source.Offset(iStart))
For Each cell In Source
If Not list.Contains(cell.Value) Then
If blAsGrp Then
If list.Count = 0 Then ReDim results(0 To 1, 0 To 0)
ReDim Preserve results(0 To 1, 0 To list.Count)
results(0, list.Count) = cell.Offset.Value
results(1, list.Count) = cell.Value
End If
list.Add cell.Value
End If
Next
End If
End With
If blAsGrp Then
getProductData = results
Else
getProductData = list.ToArray
End If
End Function
根据@RonRosenfield 和@braX 的建议，我尝试了 Scripting.Dictionary 并得出了这个答案。它既创建又检查值，这与我以前使用子创建和检查函数的方法不同。
Sub ProductNumberDictionary(strWrkShtName As String, strFindCol As String, blAsGrp As Boolean, iStart As Integer)
Dim i As Integer
Dim iLastRow As Integer
Dim iFindCol As Integer
Dim strCheck As String
Set dictProductNumber = CreateObject("Scripting.Dictionary")
With wbCurrent.Worksheets(strWrkShtName)
iFindCol = .UsedRange.Find(strFindCol, .Cells(1, 1), xlValues, xlWhole, xlByColumns).Column
iLastRow = .Cells(Rows.Count, iFindCol).End(xlUp).row
For i = iStart To iLastRow
strCheck = .Cells(i, iFindCol).Value
If dictProductNumber.exists(strCheck) = False Then
If blAsGrp = False Then
dictProductNumber.Add Key:=strCheck
Else
dictProductNumber.Add Key:=strCheck, Item:=.Cells(i, iFindCol - 1).Value
End If
End If
Next
End With
End Sub
我在从这本字典中获取值时遇到了一些困难，但发现这行得通：
Dim o as Variant
i = 0
For Each o In dictProductNumber.Keys
.Cells(iRowStart + i, iFirstCol + 1) = o 'returns the value of the key
.Cells(iRowStart + i, iFirstCol + 2) = dictProductNumber(o) 'returns the item stored with the key
i = i + 1
Next
None 关于导致您遇到的重复问题的（疯狂）猜测甚至接近。它实际上是由您的代码中的错误引起的。
在您的 IsInArray 函数中，您以错误的值完成了数组循环索引。 For i = 1 To UBound(arr, 2) 应该是 For i = 1 To UBound(arr, 2) - LBound(arr, 2) + 1。当您的索引完成一个短时，这意味着永远不会针对最后一个数组项检查比较字符串，因此，任何连续相同值中的第二个将作为副本复制。始终在索引参数中同时使用 LBound 和 UBound 以避免此类错误和类似类型的错误。
但是，此修复是多余的，因为可以重写函数以避免完全循环。我还添加了一些其他增强功能：
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim bDimen As Long
Dim i As Long
On Error Resume Next
bDimen = 2
If IsError(UBound(arr, 2)) Then bDimen = bDimen - 1
If IsError(UBound(arr, 1)) Then bDimen = bDimen - 1
On Error GoTo 0
Select Case bDimen
Case 0:
' Uninitialized array - return false
Case 1:
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2:
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, 2), 0)
On Error GoTo 0
Case Else
' Err.Raise vbObjectError + 666, Description:="Never gets here error."
End Select
End Function
这是我对字典解决方案的看法：
Public Function ProductNumberDict _
( _
ByVal TheWorksheet As Worksheet, _
ByVal Header As String, _
ByVal AsGroup As Boolean, _
ByVal Start As Long _
) _
As Scripting.Dictionary
Set ProductNumberDict = New Scripting.Dictionary
With TheWorksheet.Rows(1).Cells(WorksheetFunction.Match(Header, TheWorksheet.Rows(1), 0)).EntireColumn
Dim rngData As Range
Set rngData = TheWorksheet.Range(.Cells(Start), .Cells(Rows.Count).End(xlUp))
End With
Dim rngCell As Range
For Each rngCell In rngData
With rngCell
If Not ProductNumberDict.Exists(.Value2) Then
ProductNumberDict.Add .Value2, IIf(AsGroup, .Offset(, -1).Value2, vbNullString)
End If
End With
Next rngCell
End Function
调用函数的方法如下：
Sub UpdatePSI()
Dim wkstForecast As Worksheet
Set wkstForecast = ActiveWorkbook.Worksheets("Forecast")
' ...
Dim dictProductNumbers As Scripting.Dictionary
Set dictProductNumbers = ProductNumberDict(wkstForecast, "Item", False, 7)
Set dictProductNumbers = ProductNumberDict(wkstForecast, "Item", True, 3)
Dim iRowStart As Long: iRowStart = 2
Dim iFirstCol As Long: iFirstCol = 5
With wkstForecast.Cells(iRowStart, iFirstCol).Resize(RowSize:=dictProductNumbers.Count)
.Offset(ColumnOffset:=1).Value = WorksheetFunction.Transpose(dictProductNumbers.Keys)
.Offset(ColumnOffset:=2).Value = WorksheetFunction.Transpose(dictProductNumbers.Items)
End With
' ...
End Sub
特别注意用于将字典内容复制到工作表的非循环方法。