我撰寫了以下函式，用于獲取輸入陣列，洗掉重復項并回傳唯一值陣列。我查看了其他類似的開源功能，但也無法讓它們作業。觀察輸入陣列和函式陣列，Arr并且ArrCopy，它們對于每個索引都有正確的數字和值。任何想法為什么我會收到超出范圍的錯誤？
Public Function getUnique(Arr As Variant) As Variant
Dim ArrCopy As Variant
Dim i As Variant
Dim j As Variant
Dim counter As Integer
'copies input array, loops through copy and clears dupates
ArrCopy = Arr
For i = LBound(Arr) To UBound(Arr)
For j = LBound(ArrCopy) To UBound(ArrCopy)
If Arr(i) = ArrCopy(j) And i <> j Then
ArrCopy(j).Clear
End If
Next j
Next i
'clears array, loops through copy and puts nonzero values back in Arr
Arr.Clear
counter = 0
For i = LBound(ArrCopy) To UBound(ArrCopy)
If ArrCopy(i) <> "" Then
ReDim Preserve Arr(0 To counter)
Arr(counter) = ArrCopy(i)
counter = counter 1
End If
Next i
'returns unique values
getUnique = Arr
End Function
更新：這就是陣列的加載方式。從 FaneDuru 的評論中，我在監視表中看到輸入陣列實際上是 2D 的，所以這就是我收到超出范圍錯誤的原因......
'removes blanks from AO
wks.AutoFilterMode = False
wks.Range("A1:BO" & lastrow).AutoFilter Field:=41, Criteria1:="<>", Operator:=xlFilterValues
Set rng = wks.Range("AO2:AO" & lastrow).SpecialCells(xlCellTypeVisible)
'loads SNs into array
Erase serialNum
serialNum = rng.Value
更新 2：
This has me a lot closer. Using the 2d approach This will set all of the repeats to 0. Then I call a delete element sub I found (Deleting Elements in an Array if Element is a Certain value VBA). I am modifying the original to work with 2D array. I am getting a subscript out of range error on my Redim Preserve line within the DeleteElementAt() sub.
Public Function GetUnique(Arr As Variant) As Variant
Dim i As Variant
Dim j As Variant
Dim counter As Integer
For i = LBound(Arr) To UBound(Arr)
For j = LBound(Arr) To UBound(Arr)
If i <> j And Arr(i, 1) = Arr(j, 1) Then
Arr(j, 1) = "0"
End If
Next j
Next i
counter = 0
For i = LBound(Arr) To UBound(Arr)
If Arr(i, 1) = "0" Then
Call DeleteElementAt(i, Arr)
ReDim Preserve Arr(0 To UBound(Arr))
End If
Next i
GetUnique = Arr
End Function
Public Sub DeleteElementAt(ByVal index As Integer, ByRef Arr As Variant)
Dim i As Integer
' Move all element back one position
For i = index 1 To UBound(Arr)
Arr(index, 1) = Arr(i, 1)
Next i
' Shrink the array by one, removing the last one
'ERROR HERE
ReDim Preserve Arr(LBound(Arr) To UBound(Arr) - 1, 1)
End Sub
uj5u.com熱心網友回復：
從陣列中的范圍回傳唯一值
Option Explicit
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rg As Range: Set rg = ws.Range("A2:J21")
Dim Data As Variant: Data = GetRange(rg)
Dim Arr As Variant: Arr = ArrUniqueData(Data)
' Continue using 'Arr', e.g.:
If Not IsEmpty(Arr) Then
Debug.Print Join(Arr, vbLf)
Else
Debug.Print "Nope."
End If
' Dim n As Long
' For n = 0 To UBound(Arr)
' Debug.Print Arr(n)
' Next n
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the unique values from a 2D array
' to a 1D zero-based array, excluding error values and blanks.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueData( _
Data As Variant, _
Optional ByVal CompareMethod As VbCompareMethod = vbTextCompare) _
As Variant
Const ProcName As String = "ArrUniqueDatae"
On Error GoTo ClearError
Dim cLower As Long: cLower = LBound(Data, 2)
Dim cUpper As Long: cUpper = UBound(Data, 2)
Dim Key As Variant
Dim r As Long
Dim C As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = CompareMethod
For r = LBound(Data, 1) To UBound(Data, 1)
For C = cLower To cUpper
Key = Data(r, C)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
.Item(Key) = Empty
End If
End If
Next C
Next r
If .Count = 0 Then Exit Function
ArrUniqueData = .Keys
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
編輯
SpecialCells這將使用 ( ) 過濾的一列范圍繼續您的子程式。您仍然需要以前的程式（程式除外Test），下面有一個新功能。
' This is your procedure!
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: ...
' Calls: GetFilteredColumn
' GetRange
' ArrUniqueData
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub YourProcedure()
' ... whatever
Set Rng = wks.Range("AO2:AO" & lastrow).SpecialCells(xlCellTypeVisible)
'Erase serialNum ' you don't need to erase
serialNum = GetFilteredColumn(Rng)
Dim Arr As Variant: Arr = ArrUniqueData(serialNum)
' Continue using 'Arr', e.g.:
If Not IsEmpty(Arr) Then
Debug.Print Join(Arr, vbLf)
Else
Debug.Print "Nope."
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the filtered values of a column range
' in a 2D one-based array.
' Calls: GetRange.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredColumn( _
ByVal FilteredColumnRange As Range) _
As Variant
Const ProcName As String = "GetFilteredColumn"
On Error GoTo ClearError
With FilteredColumnRange
Dim aCount As Long: aCount = .Areas.Count
Dim aData As Variant: ReDim aData(1 To aCount)
Dim arg As Range
Dim a As Long
For Each arg In .Areas
a = a 1
aData(a) = GetRange(arg)
Next arg
Dim dData As Variant: ReDim dData(1 To .Cells.Count, 1 To 1)
Dim sr As Long
Dim dr As Long
For a = 1 To aCount
For sr = 1 To UBound(aData(a), 1)
dr = dr 1
dData(dr, 1) = aData(a)(sr, 1)
Next sr
Next a
GetFilteredColumn = dData
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
uj5u.com熱心網友回復：
當您將 Excel 范圍的值分配給 VBA 中的變數時，即使您的范圍是單列或單行，您總是會得到一個 2D 陣列，即您會得到一個尺寸為（1 到 X，1 到 1）的陣列。要獲取具有維度（1 到 X）的陣列，您需要將“獲取值”代碼封裝在 worksheetFunction.Transpose() 呼叫中。
假設您已將陣列轉換為 1D 形式，則可以使用 ArrayList 或 Scripting.Dictionary 來簡化唯一值的編譯。根本不需要對陣列 indeces 感到困惑。
這是 ArrayList 版本
Public Function getUnique(Arr As Variant) As Variant
Dim myList As Object
Set myList = CreateObject("System.collections.Arraylist")
Dim myItem As Variant
For Each myItem In Arr
If myItem <> 0 Then
If Not myList.Contains(myItem) Then
myList.Add myItem
End If
End If
Next
getUnique = myList.toarray
End Function
這是 Scripting.Dictionary 版本
Public Function getUnique(Arr As Variant) As Variant
Dim myList As Object
Set myList = CreateObject("Scripting.Dictionary")
Dim myItem As Variant
For Each myItem In Arr
If myItem <> 0 Then
If Not myList.exists(myItem) Then
myList.Add myList.Count, myItem
End If
End If
Next
getUnique = myList.Items
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/440544.html
上一篇：如何將資料拖到下一行？
下一篇：每個鍵的值的字典回圈