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

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

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

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

问题

您正在检查变量数组中的字符串。数据可以是字符串或数字,因此会产生重复数据。我建议改变你的功能 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

我猜你是因为 j 和 arrProductNumber is是全局变量。您应该通过将工作表传递给将返回数组的函数来除去全局变量。

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

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