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