How to extract data from Array in Dictionary? - arrays

Question

I'm trying to get a grasp of the VBA Dictionary.
I believe I have succeeded into storing the text of multiple cells into an array into the dictionary. But I can't find any way to get it out of there.
End goal is the ability to add multiple sources into 1 dictionary and then extract them by key or item or all at once into a new tab.
Here is the code I'm working on:
Sub tutorial_dictionary_Select()
'Must add reference to Tools > References > Microsoft Scripting Runtime
Dim dict As New Dictionary
dict.CompareMode = CompareMethod.TextCompare
Dim source As Worksheet
Set source = ActiveSheet
Dim last_row As Long
last_row = Cells(Rows.Count, 1).End(xlUp).Row
Dim last_col As Long
last_col = ActiveSheet.UsedRange.Columns.Count
Dim i As Long, n As Long
Dim hasHeader As Boolean
Dim arr(0 To 99) As Variant
If IsNumeric(Range("B1").Value) Or IsNumeric(Range("C1").Value) Then
i = 0
Else
hasHeader = True
i = 1
n = 1
For Each rngCell In Range(Cells(1, 2), Cells(1, last_col))
arr(n) = rngCell.Text
'MsgBox arr(n)
Range("I" & n) = arr(n)
Range("J" & n) = n
n = n + 1
Next rngCell
End If
Dim strVal As String
Dim Item(0 To 99) As Variant
Dim header As Range
Dim rng As Range
Dim rngTemp As Range
For Each rngCell In Range(Cells(1 + i, 1), Cells(last_row, 1))
i = i + 1
strVal = rngCell.Text
If Not dict.Exists(strVal) Then
n = 0
For Each headerCell In Range(Cells(i, 2), Cells(i, last_col))
n = n + 1
Item(n) = headerCell.Text
MsgBox headerCell.Text
Next headerCell
dict(strVal) = Item
Else
MsgBox "already exists"
End If
Next rngCell
sFruit = InputBox("Check value of key")
MsgBox "The value of " & sFruit & " is " & dict(sFruit)
The message box gives a type mismatch and I feel like I've tried everything to get those values either put in a cell or debugged and I'm clueless.
As you can see, the code it totally flexible checking for height and width (and a header). And it generates the correct items and their position in the array on the right:
https://i.imgur.com/5Ba6jaN.png

Answer 1

Yes!! That did the trick! I've been stuck on this for days, thank you so much.
Could you maybe elaborate what this code does? The script will run without the first line, but not without the second.
ar = Array()
ReDim ar(lastCol)
In case a key already exists, I want to add the amounts of the 2nd entry to what was already stored in the dictionary. I was able to figure this out myself:
Dim ws As Worksheet
Set ws = ActiveSheet
Dim dict As New Dictionary
Set dict = New Dictionary
dict.CompareMode = TextCompare
Dim lastRow As Long
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastCol As Long
lastCol = ws.UsedRange.Columns.Count
Dim i As Integer
Dim startRow As Long
startRow = 2
Dim ar As Variant
Dim sKey As String
For iRow = startRow To lastRow
sKey = ws.Cells(iRow, 1).Text
If Not dict.Exists(sKey) Then
ar = Array()
ReDim ar(lastCol)
For i = 2 To lastCol
ar(i) = ws.Cells(iRow, i)
Next
dict(sKey) = ar
Else
ar = dict(sKey)
For i = 2 To lastCol
ar(i) = ar(i) + ws.Cells(iRow, i)
Next
End If
Next
Is this the right way to do it? I expected to do something like dict(sKey)(3) = dict(sKey)(3) + ws.Cells(iRow, 3) but that didn't work.

Answer 2

You can't assign the same array to every key in the dictionary, you have to create a new one each time.
Sub tutorial_dictionary_Select()
'Must add reference to Tools > References > Microsoft Scripting Runtime
Dim dict As New Dictionary
dict.CompareMode = CompareMethod.TextCompare
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Dim last_row As Long, last_col As Long, start_row As Long
Dim hasHeader As Boolean, i As Integer, iRow As Long
last_row = ws.Cells(Rows.Count, 1).End(xlUp).Row
last_col = ws.Range("A1").CurrentRegion.Columns.Count
Debug.Print "last_col", last_col
' check for header
hasHeader = True
start_row = 2
For i = 2 To last_col
If IsNumeric(ws.Cells(1, i)) Then
hasHeader = False
start_row = 1
End If
Next
Dim ar As Variant, sKey As String
For iRow = start_row To last_row
sKey = ws.Cells(iRow, 1).Text
If Not dict.Exists(sKey) Then
ar = Array()
ReDim ar(last_col)
For i = 2 To last_col
ar(i) = ws.Cells(iRow, i)
Next
dict(sKey) = ar
End If
Next
Dim sFruit As String
sFruit = InputBox("Check value of key")
MsgBox "The value of " & sFruit & " is " & dict(sFruit)(3)
End Sub

Answer 3

Okay I've been trying to store my item + properties into an array and then multiple items in an array in a dictionary if that makes sense.
Dim ws As Worksheet
Set ws = ActiveSheet
Dim dict As New Dictionary
Set dict = New Dictionary
dict.CompareMode = TextCompare
Dim lastRow As Long
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastCol As Long
lastCol = ws.UsedRange.Columns.Count
Dim i As Long, u As Long
Dim startRow As Long
startRow = 2
Dim ar As Variant, items As Variant, item As Variant
Dim sKey As String
Dim itemAdded As Boolean
For iRow = startRow To lastRow
sKey = ws.Cells(iRow, 1).Text
item = ws.Cells(iRow, 2).Text
If Not dict.Exists(sKey) Then
MsgBox "adding new customer"
items = Array()
ReDim items(99)
ar = Array()
ReDim ar(lastCol)
'--------------------
For i = 2 To lastCol
ar(i) = ws.Cells(iRow, i)
Next
items(0) = ar
dict(sKey) = items
Else
MsgBox "customer already exists"
items = dict(sKey)
For u = LBound(items) To UBound(items)
If item = items(u)(2) Then
MsgBox "item already exists"
ar = items(u)
For i = 3 To lastCol
ar(i) = ar(i) + ws.Cells(iRow, i)
Next
items(u) = ar
dict(sKey) = items
itemAdded = True
End If
Next
If Not itemAdded = True Then
MsgBox "adding new item"
For i = 2 To lastCol
ar(i) = ws.Cells(iRow, i)
Next
items(u) = ar
dict(sKey) = items
End If
End If
Next
What is working is that I can recall Items(u)(2) and see the name of an item. But the If item = items(u)(2) Then statement is giving me a type mismatch even though it passes as true on the first loop, why? I tried declaring as String and as Variant but neither combination is working.
https://imgur.com/4eKak8q