VBAdynamic数组错误地复制了一些值
我想通过说我不知道为什么我的代码正在做它正在做的事情。 我真的希望在这里的VBA大师之一可以帮助。 另外，这是我的第一篇文章，所以我尽了最大的努力来遵守规则，但是如果我做错了，请指出。
我有一个子迭代通过一列数据，并创build一个数组。 它调用一个函数来检查特定值是否已经在数组中。 如果不是，则数组将被重新标注，插入该值，并且该过程再次开始，直到到达列表的末尾。 最后我得到了一个总共有41个值的数组，但其中4个已经被复制了两次，所以数组中只有37个唯一值。
我不能为了我的生活找出这些价值观的区别是什么，或者为什么他们被重复。 总的列表是700+的值，所以我想我应该看到其他值重复，但我不是。
这里是创build数组的子代码：
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
任何帮助都将是最受欢迎的。 我已经能够find我以前所有问题的答案（或至lessdebugging，看到一个明显的问题），但这一个难倒我。 我希望有人能弄清楚是怎么回事。
[编辑]这里是调用子的代码：
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在通用声明中定义。
（野外）猜测，没有任何关于导致您所遇到的重复问题的猜测。 它实际上是由您的代码中的错误引起的。
在你的IsInArray函数中，你完成了数组循环索引的错误值。 For i = 1 To UBound(arr, 2)应该是For i = 1 To UBound(arr, 2) - LBound(arr, 2) + 1 。 当您的索引完成一个简短的操作时，这意味着比较string从不检查最后一个数组项，因此，任何连续的相同值中的第二个将被复制为一个副本。 在索引参数中总是使用LBound和UBound来避免这种类似的错误。
但是，这种修复是多余的，因为可以重写函数来避免一个循环。 我还添加了一些其他增强function：
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
这是我的字典解决scheme：
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
特别注意用于将字典内容复制到工作表的非循环方法。
根据@RonRosenfield和@braX的build议，我尝试了一个Scripting.Dictionary并提出了这个答案。 它既创build和检查值，不像我以前的方法使用一个子创build和函数来检查。
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
问题
您正在检查变体数组中的string。 数据可能是string或数字，因此给你重复。 我build议改变你的函数Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean to Function IsInArray(stringToBeFound As Variant, arr() As Variant) As Boolean
有几个variables需要声明。 见下文。
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是全局variables。 您应该通过将工作表传递给将返回数组的函数来摆脱Globals。
您可以简单地将单元格引用添加到Scripting.Dictionary
If not dic.Exists(Cell.Value) then dic.Add Cell.Value, Cell
然后通过它的关键值检索参考
ProductOffset = dic("PID798YD").Offset(0,-1)
在这里，我使用一个ArrayList（我可以使用Scripting.Dictionary）来检查重复项，并充当Redimmultidimensional array的计数器。
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