Arrays VBA动态数组复制某些错误值

首先，我想说我完全不知道为什么我的代码会这样做。我真的希望这里的VBA专家能帮上忙。此外，这是我的第一篇帖子，所以我尽了最大努力遵守规则，但如果我做错了什么，请指出

---

我有一个sub，它遍历一列数据并创建一个数组。它调用一个函数，检查特定值是否已在数组中。如果不是，则重新对数组进行尺寸标注，插入值，然后该过程再次开始，直到到达列表的末尾。我最终得到了一个总共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

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

下面是检查

checkString

值是否在数组中的代码：

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

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

在一般声明中定义。

问题 您正在检查变量数组中的字符串。数据可以是字符串或数字，因此会提供重复项。我建议将函数IsInArray（StringToBeford作为字符串，arr作为变量）更改为布尔值，将函数IsInArray（StringToBeford作为变量，arr（）作为变量）更改为布尔值

有几个变量需要声明。见下文

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

是全局变量。您应该通过将工作表传递给将返回数组的函数来摆脱全局变量

您可以简单地将单元格引用添加到Scripting.Dictionary

If not dic.Exists(Cell.Value) then dic.Add Cell.Value, Cell

然后通过其键值检索引用

ProductOffset = dic("PID798YD").Offset(0,-1)

在这里，我使用ArrayList（我可以使用Scripting.Dictionary）来检查重复项，并充当计数器来重拨多维数组

---

---

根据@RonRosenfield和@braX的建议，我尝试了一个

Scripting.Dictionary

，并得出了这个答案。它既创建值又检查值，这与我以前的方法不同，我以前的方法使用sub来创建值，使用函数来检查值

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

到目前为止，没有人（疯狂地）猜测是什么导致了您的重复问题。它实际上是由代码中的错误引起的

在

IsInArray

函数中，以错误的值完成数组循环索引<对于i=1到UBound（arr，2）的代码>应该是

对于i=1到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

---

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

能否添加一些代码来显示如何调用第一个子字典？wbCurrent似乎在任何地方都没有定义。如果找到该值，为什么要重新确定数组的尺寸。如果该值已经存在，为什么不添加它呢？您应该考虑使用

脚本字典

，因为它有一个

.exists

方法，您可以使用它轻松创建一个不同的列表。然后可以将其转换为

数组

@braX在某些情况下，我的数组需要2个部分，而在其他情况下，只有1个部分。我这样做是为了可以在多个地方重用我的array sub。据我所知，脚本词典不允许我这样做@SJR如果未找到该值，则函数返回

False

，并添加该值。如果找到该值，则函数返回

True

，并跳过

If

语句。@primeturler确信可以。仅使用这两项，就可以使用

键

和

值

参数；或者您可以将这两个部分作为

值存储在一个数组中。@RonRosenfeld我当时觉得我做不到，但现在我不知道我是从哪里得到这个想法的。我会试试并发布一个更新。很好！有关从字典中提取值的简洁方法，请参见我的答案。我选择此答案是因为它解决了我所问的问题，而不是创建一种新的方法来回答问题（就像我使用
脚本编写.dictionary
）。添加
LBound
代码修复了问题。谢谢