VBA动态数组错误地复制了一些值

时间：2017-09-27 17:27:32

标签： arrays excel vba excel-vba dynamic-arrays

我想在前言中说我不知道​​为什么为什么我的代码正在做它正在做的事情。我真的希望这里的一位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

以下是检查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在一般声明中定义。

4 个答案:

答案 0 :(得分：1)

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

答案 1 :(得分：1)

到目前为止，没有任何（狂野的）猜测导致您所遇到的重复问题甚至接近。它实际上是由代码中的错误引起的。

在IsInArray函数中，您以错误的值完成数组循环索引。 For i = 1 To UBound(arr, 2)应为For i = 1 To UBound(arr, 2) - LBound(arr, 2) + 1。当您的索引完成一个short时，这意味着永远不会对最后一个数组项检查比较字符串，因此，任何连续相同值中的第二个将作为重复复制。始终在索引参数中同时使用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

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

答案 2 :(得分：0)

问题

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

答案 3 :(得分：0)

我猜你得到重复，因为j和arrProductNumber是全局变量。您应该通过将Worksheet传递给将返回数组的函数来摆脱Globals。

您只需将Cell引用添加到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
相关问题
最新问题