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

---

所有帮助将是最欢迎的。我之前已经能够找到我所有问题的答案（或至少调试并看到一个明显的问题），但是这个问题使我感到困惑。我希望有人能弄清楚发生了什么。

---

[edit] 这是称为子的代码：

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

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

Answer 2

根据@Ronrososeffield和@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

Answer 3

问题

您正在检查变体数组中的字符串。数据可以是字符串或数字，因此可以为您提供重复。我建议将您的功能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

Answer 4

我猜想您正在获得重复，因为j和arrProductNumber是全局变量。您应该通过将工作表传递到将返回您的数组的函数来摆脱全球。

您可以简单地将单元格引用添加到脚本。

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

然后以其密钥值

检索引用

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

在这里，我使用一个arraylist（我本可以使用脚本。

---

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