VBA Remove Item From Array at Certain Position-CodePudding

I have script where I need to loop through a value array and a support array and then once that value has been analyzed, remove it from the array and its corresponding value from the same index in the support array.

I have added an additional subroutine to remove the item that loops through the array and adds each value to a new one exlcudiung the value no longer needed but I get an error when trying to return that array back to the Main Sub.

The Error is "Variable uses an automation type not supported in VB" but I think the issue is more systemic and I am not returning the array back to the main sub correctly.

How should I return the new array back into the main sub?

Below is my Code:

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

New Sub to Remove Item:

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

CodePudding user response：

Shuffle the existing array and redim.

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

CodePudding user response：

Being a 1D array can use the next simple way, in case that shifts_array has been declared as Dim shifts_array As Variant. If not declared as I mentioned, please try declaring it in this way, if nothing from the code (we cannot see) requires a different declaration:

   max_shift = WorksheetFunction.Max(shifts_array)
   shifts_array = filter(shifts_array, max_shift, False)

You can test the next scenario, proving the above way:

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

In the above testing array, it is possible to have more Max values. Filter method, used in that way, removes all of them...

CodePudding user response：

Return it using a function instead of 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

CodePudding user response：

It looks like you are using one dimensional arrays. If this is the case then you should consider using the native Collection, or better, the ArrayList from mscorlib (ArrayList has the advantage that you can use the ToArray method to get back your array).

Both of these objects allow the removal of an item. The downside of these objects is that you need a loop to load the collection or array in the first place. However, given that you are constantly redimming each time you remove from an array, the penaly for loading a collection/arraylist on one occasion is quite minimal by comparison.

This means that in your code the lines

DeleteItem shifts_array, shift_index
DeleteItem shifts_pos_array, shift_index

would become

shifts_array.RemoveAt shift_index
shifts_pos_array.RemoveAt shift_index

and would not require the DeleteItem method.

CodePudding user response：

Remove a Match from an Array

Test the RemoveArrayNthItem Procedure

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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

All In One

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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

Test the RemoveArrayNthItem Procedure

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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

The 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

An Alternative (Useful in a Different Case)

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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

The Called Helper Functions

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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