How to use a dictionary of arrays to loop through worksheets - arrays

Question

I'm trying to make something that
loops through a range (header range) of values and collects them into an array or whatever
make a dictionary of arrays with keys that are the values in the range
loop through worksheets looking for those keys
for each key it finds,
a. make an array of the values below
b. pad all the arrays so their the same length
c. concatenate it to the array stored in the dictionary with the same key
copy the concatenated values back to the cells below the header range
I did 1,2,4 and 5. I skipped 3, because that's easy and I'll do it later. But 4 is tricky because I can't get a handle on how the dictionary and arrays work. I tried to make a dictionary of arrays, but they're making copies instead of references and sometimes the copies are empty. I don't know.
In javascript, it would just be:
make a dict = {}
loop through the values and do dict[value] = []
then dict[value].concatenate(newestarray)
Then flip the dict back in to an array with a for(var k in dict){} which in google sheets you would have to transpose. Annoying, but not terrible.
Then in the end, some function to put it back into the worksheet, which in google sheets would be trivial.
Here's my code for the 4 part:
With rws
For Each Key In headerdict 'loop through the keys in the dict
Set rrng = .Cells.Find(key, , _ 'find the key in the sheet
Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
If rrng Is Not Empty Then
'find last cell in column of data
Set rdrng = .Cells(rws.Rows.Count, rrng.Column).End(xlUp)
'get range for column of data
Set rrng = .Range(.Cells(rrng.Row + 1, rrng.Column), _
.Cells(rdrng.Row, rdrng.Column))
rArray = rrng.Value 'make an array
zMax = Max(UBound(rArray, 2), zMax) 'set max list length
fakedict(Key) = rArray 'place array in fake dict for later smoothing
End If
Next
End With
For Each Key In fakedict 'now smooth the array
If fakedict(Key) Is Not Nothing Then
nArray = fakedict(Key)
ReDim Preserve nArray(1 To zMax, 1 To 1) 'resize the array
Else
ReDim nArray(1 To zMax, 1 To 1) 'or make one from nothing
End If
fakedict(Key) = nArray 'add to fake dict
Next
Then later I can combine into the real dict. So my question is how do I resize the array? I don't think redim preserve is the best way. Others have mangled with collections, but I have too much pandas and python thinking. I'm used to deal with vectors, not munge elements. Any ideas?

Answer 1

I was not sure if you needed to use a dictionary of arrays to achieve this; if I was doing it I would just copy blocks of cells between sheets directly.
First bit - identify where the headers are:
Option Explicit
' Get the range that includes the headers
' Assume the headers are in sheet "DB" in row 1
Private Function GetHeaders() As Range
Dim r As Range
Set r = [DB!A1]
Set GetHeaders = Range(r, r.End(xlToRight))
End Function
Second, identify the sheets to scan (I assumed they're in the same workbook)
' Get all sheets in this workbook that aren't the target DB sheet
Private Function GetSheets() As Collection
Dim sheet As Worksheet
Dim col As New Collection
For Each sheet In ThisWorkbook.Worksheets
If sheet.Name <> "DB" Then col.Add sheet
Next sheet
Set GetSheets = col
End Function
Now, scan through and copy cells
' Main function, loop through all headers in all sheets
' and copy data
Sub CollectData()
Dim sheets As Collection, sheet As Worksheet
Dim hdrs As Range, hdr As Range
Dim found As Range
' This is the row we are writing into on DB
Dim currentrow As Integer
' This is the maximum number of entries under a header on this sheet, used for padding
Dim maxcount As Integer
Set sheets = GetSheets
Set hdrs = GetHeaders
currentrow = 1
For Each sheet In sheets
maxcount = 0
For Each hdr In hdrs.Cells
' Assume each header appears only once in each sheet
Set found = sheet.Cells.Find(hdr.Value)
If Not found Is Nothing Then
' Check if there is anything underneath
If Not IsEmpty(found.Offset(1).Value) Then
Set found = Range(found.Offset(1), found.End(xlDown))
' Note the number of items if it's more that has been found so far
If maxcount < found.Count Then maxcount = found.Count
' Copy cells
Range(hdr.Offset(currentrow), hdr.Offset(currentrow + found.Count - 1)) = found.Cells.Value
End If
End If
Next hdr
' Move down ready for the next sheet
currentrow = currentrow + maxcount
Next sheet
End Sub
I wrote this in Excel 2016 and tested that it worked based on my assumption of how your data is laid out.