Excel vba nested dictionary - accessing items - excel

Tim is it possible to extract a list of row keys from the clsMatrix class? something like this...
Sub KEYS()
Dim KEY_LIST As Variant
KEY_LIST = TABLES("UDLY").dR.KEYS
End Sub
I can then cycle through a table to extract a subset of data which meet a certain criteria.
Tim, your code works well for one 2D matrix, but I have 5 tables to reference for the project to work. I tried using if...then else statements, but it's clumsy and doesn't work - the second pass looking for data from the BOOK table can't find the row and col dictionary references. Can you suggest a better method? Thanks for your help.
Option Explicit
Private dR, dC
Private m_arr, UDLY, BOOK
'
Sub Init(TABLE As String)
Dim i As Long
Dim RNGE As Range
Dim DATA As Variant
Dim arr As Variant
If TABLE = "UDLY" Then Set RNGE = Worksheets("SETTINGS").Range("UDLY_TABLE")
If TABLE = "BOOK" Then Set RNGE = Worksheets("BOOK").Range("BOOK_TABLE")
arr = RNGE.Value
Set dR = CreateObject("Scripting.Dictionary")
Set dC = CreateObject("Scripting.Dictionary")
'add the row keys and positions
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
dR.Add arr(i, 1), i
Next i
'add the column keys and positions
For i = LBound(arr, 2) + 1 To UBound(arr, 2)
dC.Add arr(1, i), i
Next i
' m_arr = arr
If TABLE = "UDLY" Then UDLY = arr
If TABLE = "BOOK" Then BOOK = arr
End Sub
Function GetValue(TABLE, rowKey, colKey)
If dR.Exists(rowKey) And dC.Exists(colKey) Then
' GetValue = m_arr(dR(rowKey), dC(colKey))
If TABLE = "UDLY" Then GetValue = UDLY(dR(rowKey), dC(colKey))
If TABLE = "BOOK" Then GetValue = BOOK(dR(rowKey), dC(colKey))
Else
GetValue = 999 '"" 'or raise an error...
End If
End Function
'===========================================================
Option Explicit
Sub Tester()
Dim m As New clsMatrix
' m.Init (ActiveSheet.Range("b40").CurrentRegion.Value)
' m.Init (Worksheets("settings").Range("udly_table"))
m.Init ("UDLY")
Debug.Print m.GetValue("UDLY", "APZ4-FUT", "SPOT_OFFLINE")
m.Init ("BOOK")
Debug.Print m.GetValue("BOOK", "2.04", "STRIKE")
End Sub

Sub DICT_OF_DICT()
Dim d1, d2
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
d1.Add "BPH", "Hello"
d2.Add "Shaun", d1
Debug.Print d2("Shaun").Item("BPH")
End Sub
EDIT: if I wanted to deal with quickly accessing a 2-D array using row/column headers then I'd be inclined not to use nested dictionaries, but to use two distinct dictionaries to key into each dimension (a "row label" dictionary and a "column label" one).
You can wrap this up in a simple class:
'Class module: clsMatrix
Option Explicit
Private dR, dC
Private m_arr
Sub Init(arr)
Dim i As Long
Set dR = CreateObject("Scripting.Dictionary")
Set dC = CreateObject("Scripting.Dictionary")
'add the row keys and positions
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
dR.Add arr(i, 1), i
Next i
'add the column keys and positions
For i = LBound(arr, 2) + 1 To UBound(arr, 2)
dC.Add arr(1, i), i
Next i
m_arr = arr
End Sub
Function GetValue(rowKey, colKey)
If dR.Exists(rowKey) And dC.Exists(colKey) Then
GetValue = m_arr(dR(rowKey), dC(colKey))
Else
GetValue = "" 'or raise an error...
End If
End Function
'EDIT: added functions to return row/column keys
' return a zero-based array
Function RowKeys()
RowKeys = dR.Keys
End Function
Function ColumnKeys()
ColumnKeys = dC.Keys
End Function
Example usage: assuming A1 is the top-left cell in a rectangular range where the first row is column headers ("col1" to "colx") and the first column is row headers ("row1" to "rowy") -
EDIT2: made some changes to show how to manage multiple different tables (with no changes to the class code)
'Regular module
Sub Tester()
Dim tables As Object, k
Set tables = CreateObject("Scripting.Dictionary")
tables.Add "Table1", New clsMatrix
tables("Table1").Init ActiveSheet.Range("A1").CurrentRegion.Value
tables.Add "Table2", New clsMatrix
tables("Table2").Init ActiveSheet.Range("H1").CurrentRegion.Value
Debug.Print tables("Table1").GetValue("Row1", "Col3")
Debug.Print tables("Table2").GetValue("R1", "C3")
k = tables("Table1").RowKeys()
Debug.Print Join(k, ", ")
End Sub

Related

How to populate a Collection with a function then call the collection to fill a combo box in a userform

I am pretty new to VBA, and I would like to fill a collection with a range of cells from a worksheet. I later will want to add and subtract line items, so I need it to dynamically include all rows I need in columns 1, 2, and 3. I then need to call the function that fills the collection to fill some different combo boxes but I only want to fill the combo box with the first two columns of the collection. I would like the first column to be the key for each line item in the collection.
I have read a good bit online but I am repeatedly getting the Runtime error 91: object variable or with block variable not set. In addition I seem to be having trouble actually calling the collection function in my userform sub. This may have something to do with the structure of my code but I cannot figure out what. This may be basic but I have been trying to figure it out for quite a while and have not been able to.
Dim cCodes As Collection
Function getCodes() As Collection
Set cCodes = New Collection
Dim rRange As Range
Dim rRow As Range
Set getCodes = New Collection
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
ws.Activate
Let rRange = Range("A4:C4")
Let rRow = Range(rRange, rRange.End(xlDown))
For Each rRange In rRow
cCodes.Add rRange.Cells(0, 0), rRange.Cells(0, 1), rRange.Cells(0, 2),
Key:=rRange.Cells(0, 1)
Let rRange = rRange.Offset(1, 0)
Next rRange
Set getCodes = cCodes
End Function
Private Sub UserForm_Initialize()
dateIn.Value = Now
dateIn = Format(dateIn.Value, "mm/dd/yyyy")
sundayDate.Value = Worksheets("Sheet1").Cells(2, 24)
Dim cCodes As Collection
Set cCodes = getCodes
With UserForm1
CostCode1.List = cCodes
CostCode2.List = cCodes
CostCode3.List = cCodes
CostCode4.List = cCodes
CostCode5.List = cCodes
CostCode6.List = cCodes
End With
......more userform code
End Sub
I want it to run smoothly, for the collection to be global and always be updated with all line items in the columns specified (stop at first empty row). I will also want to use this collection in other places so need to be able to call it. Please let me know what I am doing wrong
I wouldn't use a global variable. It is a bad practice and prone to errors. Instead I'd call a Sub to build the collection and use it later like this:
Option Explicit
Sub getCodes(cCodes As Collection)
Set cCodes = New Collection
Dim rRange As Range
Dim rRow As Range
Set getCodes = New Collection
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
ws.Activate
Let rRange = Range("A4:C4")
Let rRow = Range(rRange, rRange.End(xlDown))
For Each rRange In rRow
cCodes.Add rRange.Cells(0, 0), rRange.Cells(0, 1), rRange.Cells(0, 2), Key:=rRange.Cells(0, 1)
Let rRange = rRange.Offset(1, 0)
Next rRange
End Sub
Private Sub UserForm_Initialize()
Dim cCodes As Collection
dateIn.Value = Now
dateIn = Format(dateIn.Value, "mm/dd/yyyy")
sundayDate.Value = Worksheets("Sheet1").Cells(2, 24)
getCodes cCodes
With UserForm1
CostCode1.List = cCodes
CostCode2.List = cCodes
CostCode3.List = cCodes
CostCode4.List = cCodes
CostCode5.List = cCodes
CostCode6.List = cCodes
End With
......more userform code
End Sub
So you declare only once your variable on the main sub, I think in your example that's UserForm_Initalize once you declare it there, you can pass cCodes to getCodes like this: getCodes cCodes and the procedure will build your collection ready to be used on the main procedure or the ones to come if used the same way.
Another tip is to use Option Explicit which will force you to declare all your variables and your code will be better built.
I much prefer Dictionaries over Collections. They both server functionally the same purpose, but I find Dictionaries offer advantages in terms of performance and ease of use. That being said, I think something like this is what you're looking for. This is, admittedly, fairly advanced so I commented the code to help with following what it's doing:
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Dim rData As Range
Dim hCodes As Object
Dim vKey As Variant
Dim aCols As Variant
'This is the sheet that contains the data you wanted to get the codes from
Set ws = ThisWorkbook.Worksheets("Sheet1")
'This is the range containing the codes on that sheet
Set rData = ws.Range("A4:C" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
'Create the dictionary object
Set hCodes = CreateObject("Scripting.Dictionary")
'Specify the columns you want to use for the comboboxes (1 is the first column, 2 is the second column, etc.)
'It doesn't have to be consecutive, if you want 1st and 3rd columns for example you could specify Array(1, 3)
aCols = Array(1, 2)
'Populate the dictionary using the GetCodes function (see below)
Set hCodes = GetCodes(rData, 2) 'First argument is the range to pull the codes from, the second argument is the column that contains the keys
'Loop through each key in the populated dictionary
For Each vKey In hCodes.Keys
'Populate the correct combobox based on the key (these are examples, change to what your actual keys and comboboxes will be)
'See below for the PopulateList function;
' first argument is the listbox that should be populated
' second argument is the full array of values that the list will be populated from
' third argument is the list of column numbers that will be used to pull from the provided array values
Select Case vKey
Case "a": PopulateList Me.ComboBox1, hCodes(vKey), aCols
Case "b": PopulateList Me.ComboBox2, hCodes(vKey), aCols
Case "c": PopulateList Me.ComboBox3, hCodes(vKey), aCols
Case "d": PopulateList Me.ComboBox4, hCodes(vKey), aCols
Case "e": PopulateList Me.ComboBox5, hCodes(vKey), aCols
Case "f": PopulateList Me.ComboBox6, hCodes(vKey), aCols
End Select
Next vKey
End Sub
Private Function GetCodes(ByVal arg_rData As Range, Optional ByVal arg_lKeyCol As Long = 1) As Object
'Verify the range provided and key column provided are valid
If arg_rData.Areas.Count > 1 Then
MsgBox "Invalid range provided: " & arg_rData.Address & Chr(10) & "Must be a contiguous range"
Exit Function
ElseIf arg_rData.Columns.Count < arg_lKeyCol Or arg_lKeyCol < 1 Then
MsgBox "Key Column must be >= 1 and <= Provided range's column count"
Exit Function
End If
Dim hResult As Object
Dim hIndices As Object
Dim aData() As Variant
Dim aTemp() As Variant
Dim ixNew As Long
Dim ixData As Long
Dim ixCol As Long
'Prepare the data array
If arg_rData.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = arg_rData.Value
Else
aData = arg_rData.Value
End If
'Prepare the result dictionary, and use an Indices dictionary to keep track of where data should be loaded in it
Set hResult = CreateObject("Scripting.Dictionary")
Set hIndices = CreateObject("Scripting.Dictionary")
'Loop through each row of the provided data range (we loaded it into the data array earlier)
For ixData = 1 To UBound(aData, 1)
'Check if the key already exists
If hResult.Exists(aData(ixData, arg_lKeyCol)) Then
'Key already exists, update the index so we know which row to populate to in the results
hIndices(aData(ixData, arg_lKeyCol)) = hIndices(aData(ixData, arg_lKeyCol)) + 1
Else
'Key does not exist, prepare a result array for it in the Results dictionary and set the Index to 1
ReDim aTemp(1 To WorksheetFunction.CountIf(arg_rData.Columns(arg_lKeyCol), aData(ixData, arg_lKeyCol)), 1 To UBound(aData, 2))
hResult(aData(ixData, arg_lKeyCol)) = aTemp
hIndices(aData(ixData, arg_lKeyCol)) = 1
End If
'Clear the temp array and assign it to the current key's array
Erase aTemp
aTemp = hResult(aData(ixData, arg_lKeyCol))
'Loop through each column in the data array
For ixCol = 1 To UBound(aData, 2)
'Populate the temp array with the current value from the data array
aTemp(hIndices(aData(ixData, arg_lKeyCol)), ixCol) = aData(ixData, ixCol)
Next ixCol
'Set the appropriate Key of the Results dictionary to the temp array
hResult(aData(ixData, arg_lKeyCol)) = aTemp
Next ixData
'Set the function's output the Results dictionary
Set GetCodes = hResult
End Function
Private Sub PopulateList(ByVal arg_cComboBox As Control, ByVal arg_aData As Variant, ByVal arg_aColNums As Variant)
Dim aList As Variant
Dim vCol As Variant
Dim i As Long, j As Long
'Prepare the list array
ReDim aList(LBound(arg_aData, 1) To UBound(arg_aData, 1), 1 To UBound(arg_aColNums) - LBound(arg_aColNums) + 1)
'Loop through each row of the provided data array
For i = LBound(arg_aData, 1) To UBound(arg_aData, 1)
j = 0
'Loop through only the column numbers provided
For Each vCol In arg_aColNums
'Populate the list array with the correct item from the data array
j = j + 1
aList(i, j) = arg_aData(i, vCol)
Next vCol
Next i
'Clear previous list, set the column count, and set the list to the now populated list array
With arg_cComboBox
.Clear
.ColumnCount = UBound(aList, 2)
.List = aList
End With
End Sub
This is not tested, but you can fill a combobox with an array:
Option Explicit
Function getCodes() as Variant ' intent is to return an array.
Dim rRange As Range
Let rRange = ThisWorkbook.Worksheets("Sheet1").Range("A4:C4") ' fully qualified.
Let rRange = Range(rRange, rRange.End(xlDown))
getCodes = rRange.Value ' return a 2D array that is three columns wide.
End Function
Private Sub UserForm_Initialize()
dateIn.Value = Now
dateIn = Format(dateIn.Value, "mm/dd/yyyy")
sundayDate.Value = Worksheets("Sheet1").Cells(2, 24)
With UserForm1
CostCode1.List = getCodes
CostCode2.List = getCodes
CostCode3.List = getCodes
CostCode4.List = getCodes
CostCode5.List = getCodes
CostCode6.List = getCodes
End With
......more userform code
End Sub
The use of a function instead of rolling those few lines into the main code will help future extension (e.g. adding parameters to the function to change the range where the codes are stored).

dependent dictionaries excel vba

I’d like to know which is the quickest way to get the unique values from a column and then the unique values in another column for each of the values previously found in the first column
Example
Column A Column B
Case 1 Item A
Case 1 Item B
Case 1 Item A
Case 2 Item C
Case 2 Item C
Case 3 Item D
Case 3 Item E
Case 3 Item F
Case 3 Item D
The result should return three values from the first column (Case 1, Case 2, Case 3) and then two values for Case 1 (Item A and Item B), one value for Case 2 (Item C), three values for Case 3 (Item D, Item E, Item F)
I do not want to use an advance filter or copy filtered rows in another sheet.
I tried to reach that using scripting dictionary, but I don’t know dictionary so well, and I was not able to use the keys of the first dictionary (Case 1, …) as parameters to add the items in the second dictionary (Item A, ….)
Ideally, at the end, the macro will create one textbox for each key of the first dictionary and then for each of those creates other text boxes for each key of the second dictionary (I kind of treeview but using textboxes)
Clearly, there will be a loop
Here one of the many tentatives (but, as I said, I have really poor knowledge in dictionary)
Dim d As Variant, dict As Object
Dim v As Long, a As Variant
Dim vCount As Long
Dim vCount1 As Long
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare 'default is vbbinarycompare
With Sheets("Sheet1") '<- alter to suite
a = .Range("a2", Range("a" & Rows.Count).End(xlUp)).Value
' change "a1"/ "a" to appropreate column reference
'build dictionary
For v = LBound(a, 1) To UBound(a, 1)
'overwrite method - faster (no error control)
'writes name&position as key, ID as item
'dict.Itema(v, 1)(Join(Array(vVALs(v, 2)
dict.Item(Join(Array(a(v, 1)), ChrW(8203))) = a(v, 2)
Next v
Me.ComboBox1.List = dict.Keys
Me.ComboBox2.List = dict.Values
'loop through the second table
For v = 2 To .Cells(Rows.Count, 2).End(xlUp).row
d = (Join(Array(a(v, 1))))
If dict.Exists(d) Then
vCount = dict.Item(d)
MsgBox vCount
End If
Next v
End With
What if there is a third column ?
Example
Column A Column B Column C
Case 1 Item A
Case 1 Item B number 1
Case 1 Item A number 1
Case 2 Item C number 2
Case 2 Item C number 1
Case 3 Item D number 3
Case 3 Item E number 1
Case 3 Item F number 1
Case 3 Item D number 2
the result should be
Case 1
Item A number1
Item B number1
Case 2
Item C number1
number2
Case 3
Item D number2
number3
Item E number1
Item F number1
here the code I tried to build based on Zev Spitz suggestion, but without success
Dim row As Variant
Dim dict As New Dictionary
For Each row In Sheets("Positioning").Range("h2", Range("p" &
Rows.Count).End(xlUp)).Rows
Dim caseKey As String
caseKey = row.Cells.Item(2, 1).Value
Dim innerDict As Scripting.Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Scripting.Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells.Item(2, 3).Value) = 1
Dim outerKey As Variant, innerKey As Variant, inner2Key As Variant
Dim inner2Dict As Scripting.Dictionary
For Each innerKey In innerDict.Keys
Set inner2Dict = New Scripting.Dictionary
If inner2Dict.Exists(inner2Dict) Then
Set innerDict(innerKey) = inner2Dict
Else
Set inner2Dict = inner2Dict
End If
inner2Dict(row.Cells.Item(2, 8).Value) = 1
Next
Next
For Each outerKey In dict.Keys
Debug.Print outerKey
For Each innerKey In innerDict.Keys
Debug.Print vbTab, innerKey
For Each inner2Key In inner2Dict.Keys
Debug.Print vbTab, vbTab, inner2Key
Next
Next
Next
Loading the data using nested dictionaries
You can use a dictionary which has other dictionaries as its' values:
Dim row As Variant
Dim dict As New Dictionary
For Each row In Worksheets("Sheet1").Range("A1", "B9").Rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim innerDict As Scripting.Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Scripting.Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells(1, 2).Value) = 1 'an arbitrary value
Next
Then you can iterate over each key in the outer dictionary, and iterate over each key in the inner dictionary. The following code, for example:
Dim outerKey As Variant, innerKey As Variant
For Each outerKey In dict.Keys
Debug.Print outerKey
For Each innerKey In dict(outerKey).Keys
Debug.Print vbTab, innerKey
Next
Next
will output the following:
Case 1
Item A
Item B
Case 2
Item C
Case 3
Item D
Item E
Item F
For an description of how to use a dictionary to get a unique set of values, see here.
Populating another combobox based on the selection in the first combobox
Assuming you've set the List property of the first combobox to the Keys collection of the dictionary:
Me.ComboBox1.List = dict.Keys
you can handle the Change event of the combobox, and use it to fill the second combobox with the keys of the corresponding inner dictionary:
Private Sub ComboBox1_Change()
If Value Is Nothing Then
Me.ComboBox2.List = Nothing
Exit Sub
End If
Me.ComboBox2.Value = Nothing
Me.ComboBox2.List = dict(Me.ComboBox1.Value).Keys
End Sub
Unique values using SQL
Another way to get the unique combinations of values might be to execute an SQL statement on the Excel worksheet:
SELECT DISTINCT [Column A], [Column B]
FROM [Sheet1$]
but this generally comes back as an ADO or DAO flat Recordset -- with fields and rows -- while nested dictionaries preserve the hierarchical nature of this data.
Complete code-behind
Add a reference to the Microsoft Scripting Runtime (Tools > References...)
Option Explicit
Dim dict As New Dictionary
Private Sub ComboBox1_Change()
If Value Is Nothing Then
Me.ComboBox2.List = Nothing
Exit Sub
End If
Me.ComboBox2.Value = Nothing
Me.ComboBox2.List = dict(Me.ComboBox1.Value).Keys
End Sub
Private Sub UserForm_Initialize()
For Each row In Worksheets("Sheet1").Range("A1", "B9").rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim innerDict As Dictionary
If dict.Exists(caseKey) Then
Set innerDict = dict(caseKey)
Else
Set innerDict = New Dictionary
Set dict(caseKey) = innerDict
End If
innerDict(row.Cells(1, 2).Value) = 1 'an arbitrary value
Next
Me.ComboBox1.List = dict.Keys
End Sub
Complete code behind for two dependent comboboxes
Notice that the repetitious code has been (mostly) refactored into two methods: FindOrNew and HandleComboboxChange.
Option Explicit
Dim dict As New Dictionary
Private Function FindOrNew(d As Dictionary, key As String) As Dictionary
If d.Exists(key) Then
Set FindOrNew = d(key)
Else
Set FindOrNew = New Dictionary
Set d(key) = FindOrNew
End If
End Function
Private Sub HandleComboboxChange(source As ComboBox, target As ComboBox)
If source.Value Is Nothing Then
Set target.list = Nothing
Exit Sub
End If
Set target.Value = Nothing
End Sub
Private Sub ComboBox1_Change()
HandleComboboxChange ComboBox1, ComboBox2
ComboBox2.list = dict(ComboBox1.Value).Keys
End Sub
Private Sub ComboBox2_Change()
HandleComboboxChange ComboBox2, ComboBox3
ComboBox3.list = dict(ComboBox1.Value)(ComboBox2.Value).Keys
End Sub
Private Sub UserForm_Initialize()
For Each row In ActiveSheet.Range("A1", "C9").rows
Dim caseKey As String
caseKey = row.Cells(1, 1).Value
Dim itemKey As String
itemKey = rows.Cells(1, 2).Value
Dim dictLevel2 As Dictionary
Set dictLevel2 = FindOrNew(dict, caseKey)
Dim innerDict As Dictionary
Set innerDict = FindOrNew(dictLevel2, itemKey)
innerDict(row.Cells(1, 3).Value) = 1 'an arbitrary value
Next
ComboBox1.list = dict.Keys
End Sub

Looping over each vba collection failing conflicting variable types

I'm new to VBA and am picking up pieces. I'm having a problem understanding the collection created and then looping over it to read the values against each key one at a time. My code is below.
Excel Data I'm using with the data
Suffice to say, the error I get in Excel 2016 when running the module is:
Pressing Debug shows
I'm trying to print the values against the keys. I expected 80, 20 etc.. to be printed. Could someone please help me to understand why I'm wrong in writing dataItems and how to resolve so it prints the values agains the keys - I suspect it's a for loop that's needed.
Any help would be appreciated.
Code I'm using:
Class : CItems
Option Explicit
Public Key As String
Public Sum As Long
Public Count As Long
Public ItemList As Collection
Public Function Mean() As Double
Mean = Sum / Count
End Function
Private Sub Class_Initialize()
Sum = 0
Count = 0
Set ItemList = New Collection
End Sub
Module: m_Call
Option Explicit
Sub m_Call()
''' Create Collection from Column A and B in worksheet called RAW_DATA
Dim col As Collection
Dim dataItems As cItems
Dim itemKey As String
Dim item1 As Long
Dim ws As Worksheet
Dim r As Long
Set ws = ThisWorkbook.Worksheets("RAW_DATA")
Set col = New Collection
For r = 2 To 3000
itemKey = CStr(ws.Cells(r, "A").Value2) '~~adjust to your own column(s)
item1 = CLng(ws.Cells(r, "B").Value2) '~~adjust to your own column(s)
'Check if key already exists
Set dataItems = Nothing: On Error Resume Next
Set dataItems = col(itemKey): On Error GoTo 0
'If key doesn't exist, create a new class object
If dataItems Is Nothing Then
Set dataItems = New cItems
dataItems.Key = itemKey
col.Add dataItems, itemKey
End If
'Add cell values to the class object
With dataItems
.Sum = .Sum + item1
.Count = .Count + 1
.ItemList.Add item1
End With
Next
'Iterating through all of the items
Dim i As Long
i = 5
For Each dataItems In col
Debug.Print dataItems.Mean
ws.Cells(5, i) = dataItems.Key
' read in column 5 and check search each cells content to see if it matches a collection key's string.
i = i + 1
Next
'Selecting one item
'Set dataItems = col("PersonA 1")
'ws.Cells(4, 5) = dataItems.Mean
''' Read excel and populate categories if the value in a column A cell matches with a key in the Collection.
''' Column 10 and 11 should have the values that match each Key inserted respectively.
Dim cols As Range
Dim rng As Range
Dim currentRow As Long
Dim category As Variant
' Use a With block to 'Fully Qualify' the ranges to MySheet
With ThisWorkbook.Sheets("RAW_DATA")
' Set col range to the intersection of used range and column B
Set cols = Intersect(.UsedRange, .Columns("A"))
' Loop through cells in cols to set description in each row
For Each rng In cols
currentRow = rng.Row
' Read in key's from collection
For Each dataItems In col
' read in column and search each cells content to see if it matches a collection key's string.
.Cells(currentRow, 10) = rng.Value
If rng.Value = dataItems.Key Then
.Cells(currentRow, 10) = "Working"
'Debug.Print dataItems
'''Need to insert value1 from key into Column 10 and value2 from same key into column 11.
''' I'm just testing to see if I can insert a single category first before working on the loop.
.Cells(currentRow, 10) = "Shopping"
.Cells(currentRow, 11) = dataItems
End If
Next
Next rng
End With
''' End of Read excel
End Sub
I really cannot get what you want to achieve. Also, I have the vague idea that you are overthinking your problem. With those concerns in mind, try the following and see if it helps you.
If rng.Value = dataItems.Key Then
.Cells(currentRow, 10) = "Working"
'Debug.Print dataItems
'''Need to insert value1 from key into Column 10 and value2 from same key into column 11.
''' I'm just testing to see if I can insert a single category first before working on the loop.
.Cells(currentRow, 10) = "Shopping"
For k = 1 To dataItems.Count
.Cells(currentRow, k + 11) = dataItems.ItemList(k)
Next
End If
Also, try to use the Watch Window, adding dataItems as the inspected variable. Insert a Breakpoint in your code (for example in If rng.Value = dataItems.Key Then), and step on with F8.

What is the easiest way to take two columns of data and convert to dictionary?

I have a worksheet with data in columns A and B.
I am looking for a convenient way to take these columns and convert to dictionary where the cell in column A is the key and column B is the value, something like :
Dim dict as Dictionary
Set dict = CreateDictFromColumns("SheetName", "A", "B")
NOTE: I am already referencing the scripting dll.
You would need to loop, E.g.
Function CreateDictFromColumns(sheet As String, keyCol As String, valCol As String) As Dictionary
Set CreateDictFromColumns = New Dictionary
Dim rng As Range: Set rng = Sheets(sheet).Range(keyCol & ":" & valCol)
Dim i As Long
Dim lastCol As Long '// for non-adjacent ("A:ZZ")
lastCol = rng.Columns.Count
For i = 1 To rng.Rows.Count
If (rng(i, 1).Value = "") Then Exit Function
CreateDictFromColumns.Add rng(i, 1).Value, rng(i, lastCol).Value
Next
End Function
This breaks on the first empty key value cell.
I think it'd be best form to pass two ranges to a create dictionary function. This allows for the ranges to be completely separate, even different workbooks. It also allows for a 1D range to be mapped to a 2D range as demonstrated below.
Alternatively, you could also pass two arrays of range values. That may be cleaner for 1D ranges, but would result in slightly more code for 2D mapping. Notice that range elements can be looped through left to right top to bottom by index. You can use Application.Transpose(Range("A1:A5")) to effectively run top to bottom left to right.
Jagged Mapping
Sub Test()
RangeToDict Sheets(1).Range("A1:A5"), Sheets(2).Range("C1:E2")
End Sub
Function RangeToDict(ByVal KeyRng As Range, ByVal ValRng As Range) As Dictionary
Set RangeToDict = New Dictionary
For Each r In KeyRng
vi = vi + 1
'It may not be advisable to handle empty key values this way
'The handling of empty values and #N/A/Error values
'Depends on your exact usage
If r.Value2 <> "" Then
RangeToDict.Add r.Value2, ValRng(vi)
Debug.Print r.Value2 & ", " & ValRng(vi)
End If
Next
End Function
Side-By-Side (As Range)
If your target range is a single 2 column range side by side, you can simplify to passing a single range as shown below. Consequently, this also works for mapping every other element in a 1 dimensional range.
Sub Test()
RangeToDict2 Range("A1:B5")
End Sub
Function RangeToDict2(ByVal R As Range) As Dictionary
Set RangeToDict2 = New Dictionary
i = 1
Do Until i >= (R.Rows.Count * R.Columns.Count)
RangeToDict2.Add R(i), R(i + 1)
Debug.Print R(i) & ", " & R(i + 1)
i = i + 2
Loop
End Function
Two Columns (As Array)
Lastly, as an example of passing arrays as arguments, you could do something like the following. However, the following code will only work given the OP's specific scenario of mapping two columns. As is, it won't handle mapping rows or alternating elements.
Sub Test()
Dim Keys() As Variant: Keys = Range("E1:I1").Value2
Dim Values() As Variant: Values = Range("E3:I3").Value2
RangeToDict Keys, Values
End Sub
Function RangeToDict(Keys() As Variant, Values() As Variant) As Dictionary
Set RangeToDict = New Dictionary
For i = 1 To UBound(Keys)
RangeToDict.Add Keys(i, 1), Values(i, 1)
Debug.Print Keys(i, 1) & ", " & Values(i, 1)
Next
End Function
Use of Named Ranges
It may be convenient to used named ranges, in which case you can pass a Range as an argument likes this...
Sub Test()
RangeToDict Names("Keys").RefersToRange, Names("Values").RefersToRange
End Sub
The best approach to take, is to populate a variant array with the data from the worksheet. You can then loop through the array, assigning the elements of the first array column as the dictionary key; the elements of the second array column can then be used as the value.
The lrow function is used to find the last populated row from column A - allowing the code to create a dynamically sized array and dictionary.
To enable use of dictionaries within VBA, you will need to go to Tools -> References and then enable Microsoft Scripting Runtime.
Sub createDictionary()
Dim dict As Scripting.Dictionary
Dim arrData() As Variant
Dim i as Long
arrData = Range("A1", Cells(lrow(1), 2))
set dict = new Scripting.Dictionary
For i = LBound(arrData, 1) To UBound(arrData, 1)
dict(arrData(i, 1)) = arrData(i, 2)
Next i
End Sub
Function lrow(ByVal colNum As Long) As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
End Function
This should do the trick :
Public Function test_leora(SheetName As String, _
KeyColumn As String, _
ValColumn As String) _
As Variant
Dim Dic, _
Val As String, _
Key As String, _
Ws As Worksheet, _
LastRow As Long
Set Ws = ThisWorkbook.Sheets(SheetName)
Set Dic = CreateObject("Scripting.Dictionary")
With Ws
LastRow = .Range(KeyColumn & .Rows.Count).End(xlUp).Row
For i = 1 To LastRow
Val = .Cells(i, ValColumn)
Key = .Cells(i, KeyColumn)
If Dic.exists(Key) Then
Else
Dic.Add Key, Val
End If
Next i
End With
test_leora = Dic
End Function

Compare the Sheet1 column A values with Sheet2 column B, if match then Sheet2.Col C=Sheet1.Col A and Sheet2.Col D=True

I want to compare the Sheet1 column A values with Sheet2 column B, if match then i want to put the Sheet1 Column A values in Sheet2 Column C.
and column D should be populated with 'True'
So i have written the below code:
Sub val()
Dim sheet1_last_rec_cnt As Long
Dim sheet2_last_rec_cnt As Long
Dim sheet1_col1_val As String
Dim cnt1 As Long
Dim cnt2 As Long
sheet1_last_rec_cnt = Sheet1.UsedRange.Rows.Count
sheet2_last_rec_cnt = Sheet2.UsedRange.Rows.Count
For cnt1 = 2 To sheet1_last_rec_cnt
sheet1_col1_val = Sheet1.Range("A" & cnt1).Value
For cnt2 = 2 To sheet2_last_rec_cnt
If sheet1_col1_val = Sheet2.Range("B" & cnt2).Value Then
Sheet2.Range("C" & cnt2).Value = sheet1_col1_val
Sheet2.Range("D" & cnt2).Value = "True"
Exit For
End If
Next
Next
End Sub
Problem is i have one millions of records in both the sheets.
if i use the above code then For loop is running (One million * One million) times. So excel is hanging like anything.
Can someone please help me to optimize the code?
For 1 million records I'm not sure Excel is the best place to be storing this data. If your code is designed to tidy up the data so that you can export it to a database then great ... if not, then, well, I fear rough seas lay ahead for you.
The code below will speed things up a touch as it only loops through each column once, and it populates a collection of unique values so that it only has to check against that instead of the whole column each time. If you sorted your rows then it could be made even quicker but I'll leave that one for you.
Public Sub RunMe()
Dim uniques As Collection
Dim sourceValues As Variant
Dim targetValues As Variant
Dim sourceItem As String
Dim targetItem As String
Dim sourceCount As Long
Dim targetCount As Long
Dim matches As Boolean
Dim output() As Variant
' Acquire the values to be compared.
With ThisWorkbook.Worksheets("Sheet1")
sourceValues = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
targetValues = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Resize the output array to size of target values array.
ReDim output(1 To UBound(targetValues, 1), 1 To 2)
sourceCount = 1
Set uniques = New Collection
'Iterate through the target values to find a match in the source values
For targetCount = 1 To UBound(targetValues, 1)
targetItem = CStr(targetValues(targetCount, 1))
matches = Contains(uniques, targetItem)
If Not matches Then
'Continue down the source sheet to check the values.
Do While sourceCount <= UBound(sourceValues, 1)
sourceItem = CStr(sourceValues(sourceCount, 1))
sourceCount = sourceCount + 1
'Add any new values to the collection.
If Not Contains(uniques, sourceItem) Then uniques.Add True, sourceItem
'Check for a match and leave the loop if we found one.
If sourceItem = targetItem Then
matches = True
Exit Do
End If
Loop
End If
'Update the output array if there's a match.
If matches Then
output(targetCount, 1) = targetItem
output(targetCount, 2) = True
End If
Next
'Write output array to the target sheet.
ThisWorkbook.Worksheets("Sheet2").Range("C2").Resize(UBound(targetValues, 1), 2).value = output
End Sub
Private Function Contains(col As Collection, key As String) As Boolean
'Function to test if the key already exists.
Contains = False
On Error Resume Next
Contains = col(key)
On Error GoTo 0
End Function

Resources