arrays - VBA动态数组错误地复制某些值

Question

我想以此作为序言，我不知道为什么我的代码正在做它正在做的事情。我真的希望这里的 VBA 专家之一能够提供帮助。另外，这是我的第一篇文章，所以我尽力遵守规则，但如果我做错了什么，请指出。

---

我有一个子程序，它循环访问一列数据并创建一个数组。它调用一个函数来检查特定值是否已在数组中。如果不是，则重新调整数组的大小，插入值，然后再次开始该过程，一直持续到到达列表末尾。我最终得到了一个总共 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 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 在通用声明中定义。

Answer 1

到目前为止，对于导致您遇到的重复问题的原因，没有任何(疯狂的)猜测是接近的。这实际上是由您的代码中的错误引起的。

在您的 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

特别注意用于将字典内容复制到工作表的非循环方法。