Home » excel » excel vba – Set dict = CreateObject("Scripting.Dictionary") loop until the number of sheet

excel vba – Set dict = CreateObject("Scripting.Dictionary") loop until the number of sheet

Posted by: admin April 23, 2020 Leave a comment

Questions:

I have an excel document that contains multiple sheets. When I run the loop Jumping after returning from the first sheet to the second sheet. But on the second sheet does not open a new dictionary and I get an error like “run time error 9” at ln 16. MySeries(Cnt, 2) = Dt(j, 2)

What can I do for each sheet in the opening of the new dictionary ?

        Dim Cll As Object
        Dim j As Integer
        Dim y As Integer, MySeries, Dt, MySeries1, MySeries2, MySeries3, MySeries4 As Integer, sum As Double
        For y = 1 To (Worksheets.Count - 1)
        Sheets(y).Select
        Ln = Sheets(y).Range("a1").End(4).Row
        Sheets(y).Range("d2:H" & Ln).Interior.ColorIndex = xlNone
        Dt = Sheets(y).Range("d2:h" & Ln).Value
        Set Cll = CreateObject("Scripting.Dictionary")
        ReDim MySeries(1 To Ln, 1 To 5)
           For j = 1 To UBound(Dt, 1)
                Fnd = Dt(j, 1)
                If Not Cll.exists(Fnd) Then
                    Cnt = Cnt + 1
                    Cll.Add Fnd, Cnt
                    ReDim Preserve MySeries(1 To Ln, 1 To 5)
                     MySeries(Cnt, 1) = Dt(j, 1)
                     MySeries(Cnt, 2) = Dt(j, 2)
                     MySeries(Cnt, 3) = Dt(j, 3)
                     MySeries(Cnt, 4) = Dt(j, 4)
                End If
               MySeries(Cll.Item(Fnd), 5) = MySeries(Cll.Item(Fnd), 5) + Dt(j, 5) / 1000
            Next j
            Sheets(y).Range("a2:h" & Ln).Clear
            Sheets(y).Range("d2").Resize(Cll.Count, 5) = MySeries

        Next y

Thank you for your help

How to&Answers:

cnt never gets reset to 0 anywhere in this code. Whilst this may or may not be desired behaviour for the items in the dictionary, it leads to the value of cnt exceeding the bounds of the MySeries array (which is based on ln and gets reset on each new sheet).

So, if ln was 20 for the first sheet and 15 for the second sheet, adding the first item on the second sheet will be equivalent to this:

Cnt = Cnt + 1 ' new value = 21
Cll.Add Fnd, Cnt ' should be OK
ReDim Preserve MySeries(1 To Ln, 1 To 5) ' MySeries is now (1 to 15, 1 to 5)
MySeries(Cnt, 1) = Dt(j, 1) ' MySeries(21, 1) exceeds the bounds of the array

It’s not clear why this would fail on the MySeries(Cnt, 2) = Dt(j, 2) line as it should fail on the previous line instead – MySeries(Cnt, 1) = Dt(j, 1)

edit: as per Comintern’s answer, ReDim Preserve can only change the final dimension so MySeries would get redimensioned to (1 to 20, 1 to 5) but would still fail because cnt exceeds the bounds of the array

Answer:

Redim Preserve can only change the upper-most bound of a 2 dimensional array. The reason has to do with how the data elements are laid out in memory. Consider the following array declaration:

Dim foo(1 to 4, 1 to 2)

In memory, it looks like this:

2d array 1

Now take the following statement:

ReDim Preserve foo(1 to 4, 1 to 3)

What happens is that the VBA runtime copies the data area and expands its allocated memory to allow adding additional elements (or truncates it if the 2nd dimension gets smaller). The new data area looks like this (new elements in blue):

2d array redim'd

Notice that the method of indexing by pointer offset stays the same. You will still get the same elements back with base_address + (index_one * index_two).

Now consider this statement:

ReDim Preserve foo(1 to 5, 1 to 2)

That gives the following layout in memory (new elements in red):

can't do this

Notice that there isn’t a contiguous area of memory that is being preserved. Also, the indexing of the array changes – base_address + (index_one * index_two) no longer points at the same elements once you change the first dimension’s bound. So, VBA disallows the ReDim with Preserve on everything except the last dimension and throws the somewhat cryptic “Subscript out of range” error.

So, getting to your code – the line ReDim Preserve MySeries(1 To Ln, 1 To 5) will always fail if the value of Ln changes. The only work-arounds are to manually copy the array if you need Preserve, or wipe the array and start with a fresh one.