How to create a loop in vba iterating over a list in chunks?

Viewed 325

I'm trying to create 3 sublists from the main list itemlist, but I can't find any way to achieve that. I've found a solution in python when I check out this link.

Sub CreateSubList()
    Dim itemlist As Variant, itemNum As Variant
    Dim oSublist As Variant
    
    itemlist = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11")
    
    'here I was expecting to create a variable holding sublist, as in oSublist which contains Array("1", "2", "3", "4")
    'Array("5", "6", "7", "8") and Array("9", "10", "11") in each loop
    'and finally iterate over the list in chunk to print the result
    
    For Each itemNum In oSublist
        Debug.Print itemNum
    Next itemNum
End Sub

To be specific, I'm trying to mimic this in vba:

itemlist = ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11"]

for i in range(0, len(itemlist), 4):
    chunk = itemlist[i:i + 4]
    
    for n in chunk:
        print(n)

It seems I'm very close to solve the issue.

Sub CreateSubList()
    Dim itemlist As Variant, itemNum As Variant
    Dim oSublist As Variant, iCol As Collection
    Dim inum As Variant
    
    Set iCol = New Collection

    itemlist = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11")

    For Each inum In itemlist
        iCol.Add inum
        
        If iCol.Count >= 3 Then
            For Each itemNum In iCol
                Debug.Print itemNum
            Next itemNum
            
            Debug.Print "---------------------"
            Set iCol = Nothing
            Set iCol = New Collection
        End If
    Next inum
End Sub

Output I'm getting:

1
2
3
---------------------
4
5
6
---------------------
7
8
9
---------------------

However, what is still unresolved is I can't capture the two items, as in 10 and 11 conditionally from the itemlist.

3 Answers

Option 1 - using a jagged array

CreateSubLists() returns a jagged array Array(Array(), Array(), ...) from the sliced elements of the original array.

Option Explicit

Function CreateSubLists(itemlist, count)
    Dim amount, chunks, i, j, retval, a
    amount = UBound(itemlist) - LBound(itemlist) + 1        'get the amount of the elements
    chunks = WorksheetFunction.RoundUp(amount / count, 0)   'calculate the number of chunks (e.g. if 2.5 then 3)
    
    ReDim retval(0 To chunks - 1)   'make the outer array
    For i = 0 To UBound(retval)
        'make the inner array. If the rest of the itemlist is less then chunk then get the size of the rest
        ReDim a(0 To WorksheetFunction.Min(count - 1, amount - i * count - 1))
        For j = 0 To UBound(a)
            a(j) = itemlist(i * count + j)  'fill the inner array
        Next
        retval(i) = a   'place the inner array into the outer array
    Next
    CreateSubLists = retval 'return the jagged array
End Function

Sub Example()
    Dim itemlist, chunk
    itemlist = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11")
    For Each chunk In CreateSubLists(itemlist, 4)  ' works with any positive integer number
        Debug.Print "[" & Join(chunk, ",") & "]"
    Next
End Sub

Option 2 - using Collection

Function CreateSubLists2(itemlist, count) As Collection
    Dim amount, chunks, i, j, a
    amount = UBound(itemlist) - LBound(itemlist) + 1        'get the amount of the elements
    chunks = WorksheetFunction.RoundUp(amount / count, 0)   'calculate the number of chunks (e.g. if 2.5 then 3)
    
    Dim retval As New Collection   'make the outer collection
    For i = 0 To chunks - 1
        'make the inner array. If the rest of the itemlist is less then chunk then get the size of the rest
        Set a = New Collection
        For j = 0 To WorksheetFunction.Min(count - 1, amount - i * count - 1)
            a.Add itemlist(i * count + j)  'fill the inner collection
        Next
        retval.Add a   'place the inner collection into the outer collection
    Next
    Set CreateSubLists2 = retval 'return the collection of collections
End Function

Sub Example2()
    Dim itemlist, chunk, el, s
    itemlist = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11")
    For Each chunk In CreateSubLists2(itemlist, 4)  ' works with any positive integer number
        s = "["
        For Each el In chunk
            s = s & el & ","
        Next
        s = s & "]"
        Debug.Print Replace(s, ",]", "]")
    Next
End Sub

Prints:

[1,2,3,4]
[5,6,7,8]
[9,10,11]

I do not have access to Microsoft Office or VBA at the moment but used to be quite proficient with it and wrote this just using reference on syntax from memory. I have not tested it but am pretty sure it will work, feel free to make modifications if there are syntax errors but should be pretty close.

Edit - Applied edits suggested below, I assume it works now.

' Pass chunkLength, must be smaller than length of list
Sub SubLists(chunkLength As Long)
    Dim myList As Variant
    myList = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)

    ' Length of myList divide this by chunkLength to see 
    '   how many rows output 2-dimensional array will have
    Dim listLength As Long
    listLength = UBound(myList)

    ' arrayRows is the number of rows needed in output array
    Dim arrayRows as Long
    arrayRows = -Int(-listLength / chunkLength)

    ' If we use your example of chunks of 3, this is an array (4, 3)
    ' This array has 3 subarrays with 3 elements and 1 with 2 elements
    Dim subLists() As Variant
    ' chunkLength needs to be >1 or next line is a problem
    ReDim subLists(0 To arrayRows - 1, 0 To chunkLength - 1)

    ' row index into 2-dimensional array
    Dim row As Long
    row = 0

    ' column index into 2-dimensional array
    Dim itemIndex As Long
    itemIndex = 0

    ' just a counter
    Dim listIndex As Long
    For listIndex = 0 to (listLength - 1)
        subLists(row, itemIndex) = myList(listIndex)
        If (itemIndex < chunkLength - 1) Then
            itemIndex = itemIndex + 1
        Else
            itemIndex = 0
            row = row + 1
        End If
    Next listIndex
End Sub

Notes above assume that chunks are of size 3, as in the example that you linked to, but I think this code has the desired behavior. You can pass in any chunk length that is shorter than the length of the list (but more than one - see comment in code). You could also pass in an empty array to the Sub (as a 2nd parameter, though you'd need to define your starting list and array dimensions in the calling function), so that it can be used in the calling function to access the array externally, but you would need to pass it ByRef to be able to modify it in the Sub.

I see you're using a VBA.Collection as the vessel in which to store you sublists (slices). I prefer to use the Scripting.Dictionary which can be accessed via the Tools->References menu selecting "Microsoft Scripting Runtime" (the file is location as c:\windows\system32\scrrun.dll"

I like to use the Scripting.Dictionary to arbitrarily build arrays in code because the Items method returns an array. So I can just pass this array to something like VBA.Join. Note how I use the Dictionary's count as a unique key (neat little trick), this turns it into something very similar to a Collection.

Also I have hived off the slice print logic to separate subroutine to avoid duplication. You need to call both inside the loop and after the loop.

Sub TestSimonsCreateSubList()
    Dim itemlist As Variant
    itemlist = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11")
    SimonsCreateSubList itemlist, 3
    SimonsCreateSubList itemlist, 4
    SimonsCreateSubList itemlist, 5

End Sub

Sub SimonsCreateSubList(itemlist As Variant, lSliceLen As Long)
    
    Dim inum As Variant
    
    '* Tools->References-> Microsoft Scripting Runtime (c:\windows\system32\scrrun.dll)
    Dim dicSlice As Scripting.Dictionary
    Set dicSlice = New Scripting.Dictionary

    For Each inum In itemlist
        dicSlice.Add dicSlice.Count, inum
        
        If dicSlice.Count = lSliceLen Then
            PrintSlice dicSlice
            Set dicSlice = New Scripting.Dictionary
        End If
        
    Next inum
    PrintSlice dicSlice '* don't forget to print the tail end.
End Sub

Sub PrintSlice(dicSlice As Scripting.Dictionary)
    Debug.Print VBA.Join(dicSlice.Items, vbNewLine)
    Debug.Print "---------------------"
End Sub
Related