I want to use an array of dictionaries to store all the content of an Excel workbook to later process it and make operations in memory.
I have defined that the first row of the Excel workbook is the key and the rest of rows are content. As I have one key for many values, I need to store them in a different container (this would be the array).
A sample of the content
Code Name Surname
1 a b
2 c d
The code:
For Each rcell In ws.UsedRange.Cells
If rcell.Row > 1 Then
ReDim Preserve aRows(rcell.Row - 2)
'Set aRows(rcell.Row - 2) = CreateObject("scripting.dictionary")
Set pInfo = New Scripting.Dictionary
pInfo.Add Key:=Cells(1, rcell.Column).Value, Item:=rcell.Value
'aRows(rcell.Row - 2).Add Key:=Cells(1, rcell.Column).Value, Item:=rcell.Value
Set aRows(rcell.Row - 2) = pInfo
End If
Next rcell
This code creates an array of dictionaries.
When I try to access the data I get an error.
I know that at least it is storing values because when I use:
debug.print(ubound(aRows))
I am getting the value (1) in this case.
I tried accessing the content with
for each row in aRows
debug.print(row.key)
next row
However, this is not accepted. How do I access the data?
An alternative or something more simple would be great.
May be this?
Dim d, k
For Each d in aRows
For Each k in d.keys
Debug.Print k, d(k),
Next
Debug.Print vbCrLf
Next
you could use
Dim myRow as Variant, key as variant
For Each myRow In aRows
With myRow
For Each key In .Keys
Debug.Print key, .Item(key)
Next
End With
Next
Related
I'm new to vba so I need some help making my macro more efficient. It does return the desired outcome however I know there must be a much quicker way to do so I just do not have the vba experience to know how.
I have a column which contains names of people assigned to a project. Some are only one name, and others may be multiple, for example:
At the moment, my code goes through this column, separates the names by comma, and enters them individually into a new range like so:
I then use a collection for the unique names and enter them in the final desired list. The names must show up three times, blank row, next three rows are the next name, so on.It should look like this in the end:
Currently my code is the following
Sub FindUniques()
Dim Ws As Worksheet, Ns As Worksheet
Dim SubString() As String, m As Integer, k As Long, NameCount As Integer
Dim allNames As New Collection, tempRng As Range
Set Ns = Worksheets("Sheet2")
Set Ws = Worksheets("Sheet1")
'Loops through the Assigned To column, separates and finds unique names
On Error Resume Next
For i = 1 To Ws.Range("A:A").End(xlDown).Row - Range("Assigned_to").Row
SubString = Split(Range("Assigned_to").Offset(i), ", ")
For j = 0 To UBound(SubString)
allNames.Add (allNames.count), SubString(j)
Next j
Next i
On Error GoTo 0
NameCount = allNames.count
For k = 1 To NameCount
For m = 1 To 4
Ns.Cells((k - 1) * 4 + m + 7, 2) = allNames.Key(k)
Next
Range("Names").Offset((k - 1) * 4).ClearContents
Next
End Sub
It works, however there must be some way that is more efficient than entering the names into a new range and then deleting the range. How can I use a collection or an array or something of the sort to make it quicker? Any ideas would be really appreciated
edit: I have now updated the code and it is using an collection, taking values from the substring. This enters the item (0, 1, 2, ...) in the cells instead of the keys (keys here are the names). How do I get it to return the key instead of the item number?
The slowest part of VBA are worksheet interactions so we should attempt to minimize that as much as possible.
Sub FindUniques()
Dim ws As Worksheet, ns As Worksheet
Dim splitStr() As String, nameStr As Variant
Dim dict As New Dictionary
Dim lastRow As Long, i As Long
Set ns = Worksheets("Sheet2")
Set ws = Worksheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
'Loops through the Assigned To column, separates and finds unique names
For i = 2 To lastRow
splitStr = Split(CStr(ws.Cells(i, 1).Value), ", ")
For Each nameStr In splitStr
If Not dict.Exists(nameStr) Then dict.Add nameStr , 0
Next
Next i
i = 2
For Each nameStr In dict.Keys
ns.Cells(i, 1).Resize(3).Value = nameStr
i = i + 4
Next
End Sub
Edited With #Toddleson & #BigBen 's suggestions
Good Luck!
I have Sheet1.ComboBox1 that I would like to fill with an array of values. This array is stored on Sheet2. This array is a list of all customers to be used in the excel file. All customers are listed in one single column.
Some customers appear more than once in the column. It varies by how many part numbers a customer has.
I would like to fill a Sheet1.ComboBox1 with this array, however, I don't want duplicate values.
I read online that I can convert the array into a collection which will automatically weed out duplicates.
I would like to take this collection and input it into the Sheet1.ComboBox1, however, upon some research, I've found that collections are read-only...(am I wrong in this conclusion?)
One strategy I saw was to convert the customer array into a collection and then back into a new simplified array. The hope is to store this new array into Sheet 3, then pull this array into ComboBox1.List. I've posted my code below of this attempt.
'Converts collection to an accessible array
Function collectionToArray(c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.item(i)
Next
collectionToArray = a
End Function
Sub PopulateComboBoxes()
Dim ComboBoxArray As New Collection, customer
Dim CustomerArray() As Variant
Dim newarray() As Variant
Dim i As Long
CustomerArray() = Sheet2.Range("A5:A2000")
On Error Resume Next
For Each customer In CustomerArray
ComboBoxArray.Add customer, customer
Next
newarray = collectionToArray(ComboBoxArray)
Sheet3.Range("A1:A2000") = newarray
Sheet1.ComboBox1.List = Sheet3.Range("A1:2000")
I used ' CustomerArray() = Sheet2.Range("A5:2000") ' not because there are that many rows full of values in Sheet 2, rather, that I cover all bases when more customers are eventually added to the list. The total size of my Sheet 2 is currently A1:A110, but I want to future proof it.
When I run the code, the Array is successfully reduced and the new array is placed into Sheet3 with no duplicates. However, the first Customer entry is repeated after the last unique customer value is defined. (A46 is last unique customer, A47:A2000 its the same customer repeated)
Additionally, Sheet1.ComboBox1 remains empty.
Is anyone able to explain how to restrict the number of rows filled by 'collectionToArray' , instead of filling all 2000?
Also, where am I going wrong with filling the ComboBox1? Am I missing a command/function to cause the box to fill?
You don't need that function to make a New Array, seems Excessive to me.
Assigning to CustomerArray will take care of Future Additions in column
You can directly pass on the Collection value to ComboBox
You are missing On Error Goto 0 in your code after addition to Collection. That is making all to errors after that invisible and hard for you to identify which part of code is causing problems.
Here Try this:
Sub PopulateComboBoxes()
Dim ComboBoxArray As New Collection
Dim CustomerArray() As Variant
Dim newarray() As Variant
Dim i As Long
With Worksheets("Sheet2")
CustomerArray = .Range("A5:A" & .Range("A5").End(xlDown).row).Value
End With
On Error Resume Next
For i = LBound(CustomerArray) To UBound(CustomerArray)
ComboBoxArray.Add CustomerArray(i, 1), CustomerArray(i, 1)
Next
On Error GoTo 0
For Each Itm In ComboBoxArray
Worksheets("Sheet1").ComboBox1.AddItem Itm
Next
End Sub
First, you should assign your range dynamically to CustomerArray...
With Sheet2
CustomerArray() = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
Then, you should disable error handling after you've finished adding the items to your collection. Since you did not do so, it hid the fact that your range reference in assigning the values to your listbox was incorrect, and that you didn't use the Value property to assign them. So you should disable the error handling...
On Error Resume Next
For Each customer In CustomerArray
ComboBoxArray.Add customer, customer
Next
On Error GoTo 0
Then, when transferring newarray to your worksheet, you'll need to transpose the array...
Sheet3.Range("A1").Resize(UBound(newarray) + 1).Value = Application.Transpose(newarray)
Then, as already mentioned, you should assign the items to your listbox with Sheet3.Range("A1:A2000").Value. However, since newarray already contains a list of the items, you can simply assign newarray to your listbox...
Sheet1.ComboBox1.List = newarray
So the complete code would be as follows...
Sub PopulateComboBoxes()
Dim ComboBoxArray As New Collection, customer As Variant
Dim CustomerArray() As Variant
Dim newarray() As Variant
With Sheet2
CustomerArray() = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
On Error Resume Next
For Each customer In CustomerArray
ComboBoxArray.Add customer, customer
Next
On Error GoTo 0
newarray = collectionToArray(ComboBoxArray)
Sheet3.Range("A1").Resize(UBound(newarray) + 1).Value = Application.Transpose(newarray)
Sheet1.ComboBox1.List = newarray
End Sub
it could be achieved in a number of ways. using collection or dictionary object. i am just presenting simple method without going through collection or dictionary since only 5000 rows is to be processed. it could be further shortened if used directly with combo box without using OutArr. As #Domenic already answered it with explanations, may please go along with that solution.
Option Explicit
Sub test()
Dim InArr As Variant, OutArr() As Variant
Dim i As Long, j As Long, Cnt As Long
Dim have As Boolean
InArr = ThisWorkbook.Sheets("sheet2").Range("A5:A2000")
ReDim OutArr(1 To 1)
Cnt = 0
For i = 1 To UBound(InArr, 1)
If InArr(i, 1) <> "" Then
have = False
For j = 1 To UBound(OutArr, 1)
If OutArr(j) = InArr(i, 1) Then
have = True
Exit For
End If
Next j
If have = False Then
Cnt = Cnt + 1
ReDim Preserve OutArr(1 To Cnt)
OutArr(Cnt) = InArr(i, 1)
End If
End If
Next i
Sheet3.Range("A1").Resize(UBound(OutArr)).Value = Application.Transpose(OutArr)
Sheet1.ComboBox1.Clear
Sheet1.ComboBox1.List = OutArr
Debug.Print Sheet1.ComboBox1.ListCount
End Sub
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?
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.
I have the below code I'm trying to get to work. This is my first time dealing with arrays in VBA. Here's the plain english version of what I'm going for:
Load SSBarray with column A from worksheet SSB.
Load EDMarray with Column I from worksheet EDM.
Compare the above arrays and sort into two new arrays IDarray and noIDarray based on a possible match.
Output the new arrays into their respective worksheets.
Step 4 is temporary to just make sure the code is even working. The entire project is compiling all the data from 3 sheets into these two lists. Worksheet 1 has Data point A only, Worksheet 2 may or may not have Data point A, B, and/or C, and Worksheet 3 may or may not have Data point A, B, and/or C. The code I have is my start to check for all of the data point A's in worksheet 1 are in worksheet 2. Run time is also a factor. I'll take any and all the help I can get at this point. Thanks.
'Build Arrays
Dim i As Long, j As Long
Dim SSBarray
Dim EDMarray
Dim IDarray
Dim noIDarray
Dim YCounter As Long
Dim NCounter As Long
Dim inArray As Boolean
endSSB = SSB.Range("A" & Rows.Count).End(xlUp).Row
endEDM = EDM.Range("A" & Rows.Count).End(xlUp).Row
BBlast = BB.Range("A" & BB.Range("A" & Rows.Count).End(xlUp).Row)
ReDim SSBarray(1 To endSSB)
ReDim EDMarray(1 To endEDM)
For i = 2 To endSSB
SSBarray(i) = SSB.Cells(i, 1).Value2
Next i
For i = 2 To endEDM
EDMarray = EDM.Cells(i, 9).Value2
Next i
For i = 2 To endSSB
inArray = False
For j = 2 To endEDM
If SSBarray(i) = EDMarray(j) Then
inArray = True
YCounter = YCounter + 1
ReDim Preserve IDarray(1 To YCounter)
IDarray(YCounter) = SSBarray(i)
Exit For
End If
Next j
If inArray = False Then
NCounter = NCounter + 1
ReDim Preserve noIDarray(1 To NCounter)
noIDarray(NCounter) = SSBarray(i)
End If
Next i
For i = 1 To UBound(IDarray)
Identifiers.Cells(i, 4) = IDarray(i)
Next i
For i = 1 To UBound(noIDarray)
NoIdentifiers.Cells(i, 4) = noIDarray(i)
Next i
End Sub
Revised Code:
'Sort and Compile Data
Dim i As Long
endSSB = SSB.Range("A" & Rows.Count).End(xlUp).Row
endEDM = EDM.Range("A" & Rows.Count).End(xlUp).Row
BBlast = BB.Range("A" & BB.Range("A" & Rows.Count).End(xlUp).Row)
Public Type otherIDs
SEDOL As Variant
ISIN As Variant
End Type
Dim SSBIds As New Scripting.Dictionary
Dim IDs As otherIDs
For i = 2 To endSSB
'Add an ID\row number pair
SSBIds.Add SSB.Cells(i, 1).Value2
Next i
Dim EDMIds As New Scripting.Dictionary
For i = 2 To endEDM
IDs.SEDOL = EDM.Cells(i, 8).Value2
IDs.ISIN = EDM.Cells(i, 7).Value2
EDMIds.Add EDM.Cells(i, 9).Value2, IDs.SEDOL, IDs.ISIN
Next i
Dim IdMatches As New Scripting.Dictionary
Dim IdMisMatches As New Scripting.Dictionary
Dim key As Variant
For Each key In SSBIds
'If it's in the other dictionary...
If EDMIds.Exists(key) Then
'...add the row to the matches...
IdMatches.Add key, EDMIds(key)
Else
'...otherwise add the row to the mismatches.
IdMisMatches.Add key, EDMIds(key)
End If
Next
i = 1
For Each key In IdMatches.Keys
Identifiers.Cells(i, 4) = key
Identifiers.Cells(i, 5) = IdMatches.IDs.SEDOL
Identifier.Cells(i, 6) = IdMatches.IDs.ISIN
i = i + 1
Next
i = 1
For Each key In IdMisMatches.Keys
NoIdentifiers.Cells(i, 4) = key
i = i + 1
Next
Arrays aren't the best containers to be using here. Dictionaries have an .Exists method that uses a much faster hash lookup than a simple iteration that compares every value.
Not only that, repeatedly calling Redim Preserve is incredibly inefficient compared to adding items to a Dictionary. Every time you increase the array dimension, the entire data set gets copied to a newly allocated area of memory and the data pointer for the array gets updated to point to it.
Example using Dictionaries (you'll need to add a reference to Microsoft Scripting Runtime):
Dim SSBIds As New Scripting.Dictionary
For i = 2 To endSSB
'Add an ID\row number pair
SSBIds.Add SSB.Cells(i, 1).Value2, i
Next i
Dim EDMIds As New Scripting.Dictionary
For i = 2 To endEDM
EDMIds.Add EDM.Cells(i, 9).Value2, i
Next i
Dim IdMatches As New Scripting.Dictionary
Dim IdMisMatches As New Scripting.Dictionary
Dim key As Variant
For Each key In SSBIds
'If it's in the other dictionary...
If EDMIds.Exists(key) Then
'...add the row to the matches...
IdMatches.Add key, EDMIds(key)
Else
'...otherwise add the row to the mismatches.
IdMisMatches.Add key, EDMIds(key)
End If
Next
i = 1
For Each key In IdMatches.Keys
Identifiers.Cells(i, 4) = key
i = i + 1
Next
i = 1
For Each key In IdMisMatches.Keys
NoIdentifiers.Cells(i, 4) = key
i = i + 1
Next
Note that this assumes that your key columns have unique values. If they don't, you can either test for the presence of the key before adding a value (this matches your code's behavior of only taking the first match), or you can create a Collection of values to store in the Dictionary for each key, or something else entirely depending on your requirement.
The code below is meant to read columns from an Excel table into arrays, which can then be used to determine whether each "Project" belongs to the Environment "Group", and if so, to add the project number and dollar value to another array. I am having some issues with my code, and have been searching the internet and StackOverflow but have been able to find very little information on dealing with Excel Tables using VBA. I am using Excel 2010.
Sub UpdateProjectsAndCharges()
'Define arrays to be used
Dim projectArray() As Variant
Dim uniqueProjectArray(100) As Variant
Dim dollarValue() As Variant
Dim envProjectArray(100) As Variant
Dim envDollarValue(100) As Double
Dim cumulativeCosts(100) As Double
'Define all tables in this sheet as list objects
Dim UnitsValues As ListObject
Dim ChargingTracking As ListObject
'Define counters to be used
Dim counter As Integer
Dim counter2 As Integer
'Set variables for each table in sheet
Set UnitsValues = Sheets("Cluster Data").ListObjects("UnitsValues")
Set ChargingTracking = Sheets("Cluster Data").ListObjects("ChargingTracking")
'Find last row in table
With Sheets("Cluster Data")
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
End With
'Define variables to be used in loops
Dim userGroup As Variant
Dim project As Variant
Dim Value As Variant
'Set arrays to respective columns from UnitsValues table
userGroups = Range("UnitsValues[Group]")
projectArray = Range("UnitsValues[Project]")
dollarValue = Range("UnitsValues[Dollar Value]")
'Redefine length of arrays to number of rows in table
ReDim Preserve projectArray(lastRow)
ReDim Preserve dollarValue(lastRow)
'Set counter values
counter = 1
counter2 = 1
For Each userGroup In userGroups
project = projectArray(counter)
Value = dollarValue(counter)
If userGroup = "Environment" Then
envProjectArray(counter2) = project
envDollarValue(counter2) = Value
counter2 = counter2 + 1
MsgBox ((envProjectArray(counter2) & " " & envDollarValue(counter2)))
End If
counter = counter + 1
Next userGroup
I was receiving the "Subscript out of range" error with these lines:
project = projectArray(counter)
Value = dollarValue(counter)
I looked up the error and thought that these lines would perhaps fix the problem:
ReDim Preserve projectArray(lastRow)
ReDim Preserve dollarValue(lastRow)
Now, I am receiving the same error on the lines above instead, and have run out of ideas on how to fix the error. I suspect it is happening because I assigned a range into an array, but I'm not certain.
Change:
project = projectArray(counter)
Value = dollarValue(counter)
to
project = projectArray(counter, 1)
Value = dollarValue(counter, 1)
Arrays read from worksheets always are multidimensional even if you just have 1 column.
In this case you are specifying that column to be 1, every time.