我有腳本，我需要遍歷一個值陣列和一個支持陣列，然后一旦分析了該值，就將其從陣列中洗掉，并從支持陣列中的同一索引中洗掉其對應的值。
我添加了一個額外的子例程來洗掉回圈遍歷陣列的專案，并將每個值添加到一個新的值中，排除不再需要的值，但是在嘗試將該陣列回傳到 Main Sub 時出現錯誤。
錯誤是“變數使用了 VB 不支持的自動化型別”，但我認為這個問題更系統化，我沒有正確地將陣列回傳到主子。
我應該如何將新陣列回傳到主子中？
下面是我的代碼：
If viable_shift Then
For i = LBound(shifts_array) To UBound(shifts_array)
max_shift = WorksheetFunction.Max(shifts_array)
shift_index = Application.Match(max_shift, shifts_array, False) - 1
shift_pos = shifts_pos_array(shift_index)
If supplied_heads - max_shift >= required_heads Then
ShiftingSheet.Cells(shift_pos, col).Value = ""
heads_supplied = heads_supplied - max_shift
End If
DeleteItem shifts_array, shift_index
DeleteItem shifts_pos_array, shift_index
Next i
' Redefine variables
Erase shifts_array
Erase shifts_pos_array
ReDim shifts_array(0)
ReDim shifts_pos_array(0)
i = 0
End If
洗掉專案的新子項：
Sub DeleteItem(ByRef arr, v)
Dim new_arr(), i As Double, x As Double
ReDim new_arr(LBound(arr) To UBound(arr) - 1)
x = 0
For i = LBound(arr) To UBound(arr)
If i <> v Then
new_arr(i - x) = arr(i)
Else
x = 1
End If
Next i
arr = new_arr ' error is here
End Sub
uj5u.com熱心網友回復：
對現有陣列進行洗牌并重新整理。
Sub DeleteItem(ByRef arr, v As Long)
Dim i As Long, n As Long
n = UBound(arr)
If v <= n And v >= LBound(arr) Then
For i = v To n - 1
arr(i) = arr(i 1)
Next i
ReDim Preserve arr(n - 1)
End If
End Sub
uj5u.com熱心網友回復：
作為一維陣列可以使用下一個簡單的方法，以防shifts_array已宣告為Dim shifts_array As Variant. 如果沒有像我提到的那樣宣告，請嘗試以這種方式宣告它，如果代碼中沒有任何內容（我們看不到）需要不同的宣告：
max_shift = WorksheetFunction.Max(shifts_array)
shifts_array = filter(shifts_array, max_shift, False)
可以測驗下一個場景，證明上面的方式：
Sub testFilterArr()
Dim shifts_array, i As Long, max_shift
ReDim shifts_array(10)
For i = 0 To UBound(shifts_array)
shifts_array(i) = CLng(UBound(shifts_array) * Rnd())
Next
Debug.Print Join(shifts_array, "|")
max_shift = WorksheetFunction.Max(shifts_array)
shifts_array = Filter(shifts_array, max_shift, False)
Debug.Print Join(shifts_array, "|")
End Sub
在上面的測驗陣列中，可以有更多的Max值。Filter以這種方式使用的方法會洗掉所有這些......
uj5u.com熱心網友回復：
使用函式而不是ByRef...回傳它
Private Function DeleteItem(ByVal arr, ByVal v As Long) As Variant
Dim new_arr(), i As Double, x As Double
ReDim new_arr(LBound(arr) To UBound(arr) - 1)
x = 0
For i = LBound(arr) To UBound(arr)
If i <> v Then
new_arr(i - x) = arr(i)
Else
x = 1
End If
Next i
DeleteItem = new_arr
End Function
uj5u.com熱心網友回復：
看起來您正在使用一維陣列。如果是這種情況，那么您應該考慮使用本機 Collection，或者更好的是來自 mscorlib 的 ArrayList（ArrayList 的優點是您可以使用 ToArray 方法取回您的陣列）。
這兩個物件都允許移除一個專案。這些物件的缺點是首先需要一個回圈來加載集合或陣列。但是，考慮到每次從陣列中洗掉時都在不斷地重新變暗，相比之下，一次加載集合/陣列串列的代價非常小。
這意味著在您的代碼中
DeleteItem shifts_array, shift_index
DeleteItem shifts_pos_array, shift_index
會成為
shifts_array.RemoveAt shift_index
shifts_pos_array.RemoveAt shift_index
并且不需要 DeleteItem 方法。
uj5u.com熱心網友回復：
從陣列中洗掉匹配項
測驗RemoveArrayNthItem程式
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls: ArrSequenceOfIntegers,StrJoinedArray,RemoveArrayMatch.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RemoveArrayMatchTEST()
Const MatchValue As Long = 16
Dim Arr As Variant: Arr = ArrSequenceOfIntegers(25, 1, 3, 0)
Debug.Print "[LB=" & LBound(Arr) & "," & "UB=" & UBound(Arr) & "] " _
& StrJoinedArray(Arr, ", ")
RemoveArrayMatch Arr, MatchValue
Debug.Print "[LB=" & LBound(Arr) & "," & "UB=" & UBound(Arr) & "] " _
& StrJoinedArray(Arr, ", ")
End Sub
一體
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Removes the first element, matching a value, from an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RemoveArrayMatch( _
ByRef Arr As Variant, _
ByVal MatchValue As Variant)
Const ProcName As String = "RemoveArrayMatch"
On Error GoTo ClearError
Dim mIndex As Variant: mIndex = Application.Match(MatchValue, Arr, 0)
If IsError(mIndex) Then Exit Sub
Dim LB As Long: LB = LBound(Arr)
Dim UB As Long: UB = UBound(Arr)
Dim n As Long: n = LB - 1
If mIndex > 0 And mIndex <= UB - n Then
For n = mIndex n To UB - 1
Arr(n) = Arr(n 1)
Next n
ReDim Preserve Arr(LB To n - 1)
End If
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
測驗RemoveArrayNthItem程式
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls: ArrSequenceOfIntegers,StrJoinedArray,RemoveArrayNthItem.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RemoveArrayNthItemTEST()
Const MatchValue As Long = 16
Dim Arr As Variant: Arr = ArrSequenceOfIntegers(25, 1, 3, 0)
Debug.Print "[LB=" & LBound(Arr) & "," & "UB=" & UBound(Arr) & "] " _
& StrJoinedArray(Arr, ", ")
Dim mIndex As Variant: mIndex = Application.Match(MatchValue, Arr, 0)
If Not IsError(mIndex) Then
RemoveArrayNthItem Arr, mIndex
End If
Debug.Print "[LB=" & LBound(Arr) & "," & "UB=" & UBound(Arr) & "] " _
& StrJoinedArray(Arr, ", ")
End Sub
潛艇
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Removes the n-th element from an array.
' Remarks: 'Nth' refers to element 'Arr(n LBound(Arr) - 1)'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RemoveArrayNthItem( _
ByRef Arr As Variant, _
ByVal Nth As Long)
Const ProcName As String = "RemoveArrayNthItem"
On Error GoTo ClearError
Dim LB As Long: LB = LBound(Arr)
Dim UB As Long: UB = UBound(Arr)
Dim n As Long: n = LB - 1
If Nth > 0 And Nth <= UB - n Then
For n = Nth n To UB - 1
Arr(n) = Arr(n 1)
Next n
ReDim Preserve Arr(LB To n - 1)
End If
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
替代方案（在不同情況下有用）
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Removes the item, indicated by its index, from an array.
' Remarks: 'Index' refers to element 'Arr(Index)'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RemoveArrayItemByIndex( _
ByRef Arr As Variant, _
ByVal Index As Long)
Const ProcName As String = "RemoveArrayItemByIndex"
On Error GoTo ClearError
Dim LB As Long: LB = LBound(Arr)
Dim UB As Long: UB = UBound(Arr)
Dim n As Long: n = LB - 1
If Index > 0 And Index <= UB - n Then
For n = Index To UB - 1
Arr(n) = Arr(n 1)
Next n
ReDim Preserve Arr(LB To n - 1)
End If
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
被呼叫的輔助函式
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a sequence of integers in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrSequenceOfIntegers( _
ByVal StartInteger As Long, _
ByVal EndInteger As Long, _
Optional ByVal StepInteger As Long = 1, _
Optional ByVal ArrayBase As Long = 0) _
As Variant
Dim IsStepPositive As Boolean: IsStepPositive = (StartInteger <= EndInteger)
Dim siCount As Long
If IsStepPositive Then
siCount = EndInteger - StartInteger 1
Else
siCount = StartInteger - EndInteger 1
End If
Dim siStep As Long: siStep = Abs(StepInteger)
Dim drCount As Long: drCount = Int(siCount / siStep)
If siCount Mod siStep > 0 Then
drCount = drCount 1
End If
If Not IsStepPositive Then
siStep = -siStep
End If
Dim dr As Long: dr = ArrayBase - 1
Dim Arr() As Long: ReDim Arr(ArrayBase To drCount dr)
Dim si As Long
For si = StartInteger To EndInteger Step siStep
dr = dr 1
Arr(dr) = si
Next si
ArrSequenceOfIntegers = Arr
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of an array in a delimited string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrJoinedArray( _
ByVal Arr As Variant, _
Optional ByVal Delimiter As String = " ") _
As String
Const ProcName As String = "StrJoinedArray"
On Error GoTo ClearError
Dim n As Long
Dim nString As String
For n = LBound(Arr) To UBound(Arr)
nString = nString & CStr(Arr(n)) & Delimiter
Next n
StrJoinedArray = Left(nString, Len(nString) - Len(Delimiter))
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/401376.html