Right so I have an excel program that loops through multiple pdfs and extracts data from them. In order for this to work it uses a rubric looking at key values of Named Ranges which are RubricItems, RatingsValuesRow, and RatingsColumn. I must use the named Ranges because the rubric could change at any given time. Bellow is the snippet of code I'm having issues with.
For this rubricItemC.value = 1 , subRubricItem = a , ratCell = 4
Dim ratingsCol As Range
Dim ratingsVal As Range
Dim rubricItem As Range
Dim rubricItemC As Range
Dim subRubricItem As Range
Dim gradeCount As Integer
Dim c As Range
Dim ratCount As Range
Dim ratCell As Range
count = 0
gradeCount = 0
Set rubricItem = Workbooks(strRubricTemplateFilename).Worksheets(RubricSheet).Range("RubricItems")
Set ratingsVal = Workbooks(strRubricTemplateFilename).Worksheets(RubricSheet).Range("RatingsValuesRow")
Set ratingsCol = Workbooks(strRubricTemplateFilename).Worksheets(RubricSheet).Range("RatingsColumn")
'populates the ratings values which consist of [X,1,2,3,4]
For Each c In ratingsVal.Cells
If Not (c.Value = "") Then
gradeValuesDict.Add c.Value, gradeCount
End If
Next
'iterates through each item in the rubric
For Each c In rubricItem.Cells
Set rubricItemC = c
Set ratCell = Cells(rubricItemC.Row, ratingsCol.Column)
Set subRubricItem = rubricItemC.offset(0, 1)
'checks to see if the dictionary exist if not create it.
If Not dict.Exists(rubricItemC.Value) Then
'adds to the dictionary passing another dictionary as the item.
dict.Add rubricItemC.Value, subRubricDict
End If
'checks to see if the sub dictionary exists if not create it.
If Not dict.Item(rubricItemC.Value).Exists(subRubricItem.Value) Then
dict.Item(rubricItemC.Value).Add subRubricItem.Value, gradeValuesDict
End If
dict.Item(rubricItemC.Value).Item(subRubricItem).Item(ratCell) = dict.Item(rubricItemC.Value).Item(subRubricItem).Item(ratCell) + 1
Next
This is where I am getting my Object Required Error.
dict.Item(rubricItemC.Value).Item(subRubricItem).Item(ratCell) = dict.Item(rubricItemC.Value).Item(subRubricItem).Item(ratCell) + 1
I'm fairly new to VBA but what Im attempting to do here is reference the gradeCount within the multiple levels of dictionarys and increase the value by 1.
The Dictionary object accepts object references as keys. For this reason, when you enter an item with some Range object as a key, you cannot retrieve the same item using the range's value as key, it will not find it. The same applies if you add an item with value and try to retrieve it by the range object (reference).
As a general rule, if your key in .Add is a Range, use the same range object as a key in .Item. On the other hand, if your key in .Add is a Range.Value (this is what you actually want to do), use the same value as a key in .Item.
dict.Item(rubricItemC.Value).Item(subRubricItem.Value).Item(ratCell.Value) = dict.Item(rubricItemC.Value).Item(subRubricItem.Value).Item(ratCell.Value) + 1
Related
I have seen multiple codes regarding this topic but I can't seem to understand it.
For instance, if I have a column that records people names, I want to record all unique names into the array.
So if I have a column of names
David
Johnathan
Peter
Peter
Peter
Louis
David
I want to utilize VBA to extract unique names out of the column and place it into an array so when I call the array it would return these results
Array[0] = David
Array[1] = Johnathan
Array[2] = Peter
Array[3] = Louis
Despite a Collection being mentioned and being a possible solution, it is far more efficient to use a Dictionary as it has an Exists method. Then it's just a matter of adding the names to the dictionary if they don't already exist, and then extracting the keys to an array when you're done.
Note that I've made the name comparisons case-sensitive, but you can change that if necessary, to case-insensitive.
Option Explicit
Sub test()
'Extract all of the names into an array
Dim values As Variant
values = Sheet1.Range("Names").Value2 'Value2 is faster than Value
'Add a reference to Microsoft Scripting Runtime
Dim dic As Scripting.Dictionary
Set dic = New Scripting.Dictionary
'Set the comparison mode to case-sensitive
dic.CompareMode = BinaryCompare
Dim valCounter As Long
For valCounter = LBound(values) To UBound(values)
'Check if the name is already in the dictionary
If Not dic.Exists(values(valCounter, 1)) Then
'Add the new name as a key, along with a dummy value of 0
dic.Add values(valCounter, 1), 0
End If
Next valCounter
'Extract the dictionary's keys as a 1D array
Dim result As Variant
result = dic.Keys
End Sub
use Dictionary object and build a Function that returns your array
Function GetUniqeNames(myRng As Range) As Variant
Dim cell As Range
With CreateObject("Scripting.Dictionary") ' instantiate and reference a Dictionary object
For Each cell In myRng ' loop through passed range
.Item(cell.Value2) = 1 ' store current cell name into referenced dictionary keys (duplicates will be overwritten)
Next
GetUniqeNames = .keys ' write referenced dictionary keys into an array
End With
End Function
that you can exploit in your main code as follows
Sub main()
Dim myArray As Variant
With Worksheets("mysheet") ' change "mysheet" to your actual sheet name
myArray = GetUniqeNames(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp))) ' this will take the referenced sheet column A range from row 1 down to last not empty one
End With
End Sub
Is this a VBA question or a question about programming logic? Use a loop on the column with the data. Check each name against the list of existing data items. If it exists in the list, move on the the next name. If it does not exist in the list, add it.
The "list" is a concept, not a concrete tool. It can be a VBA dictionary, if you are comfortable using that. Or it can be a VBA array, which may not perform as fast as a dictionary, but may be more familiar.
Then again, if you add the data to the Excel Data Model, you can use the Distinct aggregation of a pivot table to list out the unique values.
Without more background it's hard to tell if VBA or Data Model is your best approach. Many VBA solutions get created because people are not aware of Excel's capabilities.
You could use Excel functionality like that.
Sub UniqueNames()
Dim vDat As Variant
Dim rg As Range
Dim i As Long
Set rg = Range("A1:A7")
rg.RemoveDuplicates Columns:=Array(1), Header:=xlNo
With ActiveSheet
vDat = WorksheetFunction.Transpose(.Range("A1:" & .Range("A1").End(xlDown).Address))
End With
For i = LBound(vDat) To UBound(vDat)
Debug.Print vDat(i)
Next i
End Sub
Code is based on your example data, i.e. I put your data into column 1. But the code will also alter the table. If you do not want that you have to use other solutions or put the data beforehand in a temporary sheet.
If you dont want to use "Scripting.Dictionary" and your excel does not have Worksheet.unique(...) like mine
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
If UBound(arr) >= 0 Then
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
Else
IsInArray = False
End If
End Function
Public Function GetUniqueValuesFromColumn(ws As Worksheet, sourceColNum As Long, Optional firstRow As Long = 2) As Variant
Dim val As String
Dim i As Long
Dim arr() As Variant
arr = Array()
For i = firstRow To ws.Cells(Rows.Count, sourceColNum).End(xlUp).Row
val = ws.Cells(i, sourceColNum)
If Not IsInArray(val, arr) Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = val
End If
Next i
GetUniqueValuesFromColumn = arr
End Function
Then call it like GetUniqueValuesFromColumn(ThisWorkbook.Worksheets("SomeList"), 1)
How do you go about creating excel VBA dictionaries?
Say I have the following values:
How can I set column A as the key, column B as the value?
Do I loop through every value to store?
How do I go about using the dictionary afterward to get the value of 5 for instance ("Key A")
In Excel:
=VLOOKUP("D", A:B, 2,FALSE)
returns 20.
In VBA:
MsgBox WorksheetFunction.VLookup("D", Sheet1.Range("A:B"), 2, False)
pops 20.
putting answer here for documentation purposes, from reddit user MRMCMLXXXV
source https://www.reddit.com/r/excel/comments/6u4swi/how_do_you_create_a_dictionary_in_excel_vba_and/
Public Sub DictionaryExamples()
Dim exampleValues As Variant
Dim i As Long
Dim aKey As String
Dim aValue As Integer
Dim exampleDict As Object
'Load values into a variant array
exampleValues = Range("A1:B10").Value
'Instantiate a dictionary
Set exampleDict = CreateObject("scripting.dictionary")
'Read all keys and values, and add them to the dictionary
For i = 1 To UBound(exampleValues)
aKey = CStr(exampleValues(i, 1))
aValue = CInt(exampleValues(i, 2))
exampleDict.Add aKey, aValue
Next i
'Output the value associated with key A
MsgBox exampleDict.Item("A")
End Sub
The result looks like this in excel
I am trying to create a dynamic number of variables in VBA based on the value in a cell.
Essentially what I'd like to end up with is something like Team1, Team2... to TeamX.
Any help is greatly appreciated
Dim i, x As Integer
Set x = Range("J4").Value
Dim Team(1 To x) As String
Dim Manager(1 To x) As String
Range("A3").Select
For i = 1 To x
Dim Team(i) As Integer
A dictionary would probably help in this case, it's designed for scripting, and while it won't let you create "dynamic" variables, the dictionary's items are dynamic, and can serve similar purpose as "variables".
Dim Teams as Object
Set Teams = CreateObject("Scripting.Dictionary")
For i = 1 To x
Teams(i) = "some value"
Next
Later, to query the values, just call on the item like:
MsgBox Teams(i)
Dictionaries contain key/value pairs, and the keys must be unique. Assigning to an existing key will overwrite its value, e.g.:
Teams(3) = "Detroit"
Teams(3) = "Chicago"
Debug.Print Teams(3) '## This will print "Chicago"
You can check for existence using the .Exist method if you need to worry about overwriting or not.
If Not Teams.Exist(3) Then
Teams(3) = "blah"
Else:
'Teams(3) already exists, so maybe we do something different here
End If
You can get the number of items in the dictionary with the .Count method.
MsgBox "There are " & Teams.Count & " Teams.", vbInfo
A dictionary's keys must be integer or string, but the values can be any data type (including arrays, and even Object data types, like Collection, Worksheet, Application, nested Dictionaries, etc., using the Set keyword), so for instance you could dict the worksheets in a workbook:
Dim ws as Worksheet, dict as Object
Set dict = CreateObject("Scripting.Dictionary")
For each ws in ActiveWorkbook.Worksheets
Set dict(ws.Name) = ws
Next
This will get you started. But before you start I recommend watching these WiseOwlTutorials tutorial on Youtube:
Selecting Cells (Range, Cells, Activecell, End, Offset)
Worksheets, Charts and Sheets
Variables
Arrays
Dim i, x As Integer
x = Range("J4").Value
Dim Team() As Integer
Dim Manager() As String
ReDim Team(1 To x) As Integer
ReDim Manager(1 To x) As String
Range("A3").Select
For i = 1 To x
Team(i) = i
Next
I have a workbook in which there are 5 sheets :
prize
volatility
size
value
growth
These five sheets have a ticker list (stocks name on index) in columns along with the dates . After every three months a new ticker list comes as a result of rebalancing for e.g. PRIZE sheet is having 2 rebalances so 2 ticker lists and SIZE sheet is having 4 rebalances so 4 ticker lists, so all these ticker lists are presented in the five different sheets. I want to make a macro which picks distinct unique values from these lists and paste it in another sheet in one column.
This will require a reference to the Microsoft Scripting Runtime. Go to the VB Editor, then Tools, References and select it from there.
After that, paste this code in a proc and see if it gets you over the line. It'll certainly push your knowledge in a new direction - dictionaries and arrays are amazing things in the right hands and utterly doom-laden in the wrong hands. You've been warned...!
Dim dctUniqueTickers As Dictionary
Dim dctTickerLocations As Dictionary
Dim arrCurrentTickerRange As Variant
Dim arrTickerOutput As Variant
Dim varSheetNames As Variant
Dim lngDctCounter As Long
Dim lngRowCounter As Long
Dim lngColCounter As Long
Dim lngAreaCounter As Long
' Set up the ticker location range(s)
Set dctTickerLocations = New Dictionary
With dctTickerLocations
.Add "prize", Application.Union(ThisWorkbook.Worksheets("prize").Range("A:A"), _
ThisWorkbook.Worksheets("prize").Range("C:C"))
.Add "size", Application.Union(ThisWorkbook.Worksheets("size").Range("A:A"), _
ThisWorkbook.Worksheets("size").Range("E:E"), _
ThisWorkbook.Worksheets("size").Range("F:F"), _
ThisWorkbook.Worksheets("size").Range("H:H"))
End With
' Populate the destination dictionary
Set dctUniqueTickers = New Dictionary
For Each varSheetNames In dctTickerLocations.Keys
' Looping through the keys (the worksheet names), pick up the associated range(s)
' - there may be multiple areas to consider
For lngAreaCounter = 1 To dctTickerLocations(varSheetNames).Areas.Count
arrCurrentTickerRange = dctTickerLocations(varSheetNames).Areas(lngAreaCounter)
For lngRowCounter = LBound(arrCurrentTickerRange, 1) To UBound(arrCurrentTickerRange, 1)
For lngColCounter = LBound(arrCurrentTickerRange, 2) To UBound(arrCurrentTickerRange, 2)
If LenB(arrCurrentTickerRange(lngRowCounter, lngColCounter)) > 0 Then
If Not dctUniqueTickers.Exists(arrCurrentTickerRange(lngRowCounter, lngColCounter)) Then
' Ticker not found within the dictionary, so add it
dctUniqueTickers.Add arrCurrentTickerRange(lngRowCounter, lngColCounter), arrCurrentTickerRange(lngRowCounter, lngColCounter)
End If
End If
Next
Next
Next
Next
If dctUniqueTickers.Count > 0 Then
lngDctCounter = 0
' Now output
ThisWorkbook.Worksheets("OutputSheet").Range("A1").Value = "Unique tickers"
For Each arrTickerOutput In dctUniqueTickers.Keys
ThisWorkbook.Worksheets("OutputSheet").Range("A2").Offset(lngDctCounter, 0).Value = CStr(arrTickerOutput)
lngDctCounter = lngDctCounter + 1
Next
End If
By using arrays it's lightning-fast and the extra check for empty cells only improves performance.
I currently have a method which takes in a dynamic named range in excel and converts it to a 2D array.
I need to do some iterations to the data and carry out a Delete function if a certain column contains a value. I have looked at the options out there for deleting rows in 2d array using transpose and temp array and since my data is fairly large I am looking at other data structures that would make it easier to delete entire rows.
I want to convert a dynamic named range into a collection in vba. This collection will have a key the row number and as item should have all the data for that row. Basically I would need the ability to iterate through each value in that range like I can do with a 2D array but also the ability to delete a row efficiently and with less hassle than using a 2D array.
Anybody have an idea on how I can achieve this?
Dim srcArray () As Variant
Dim srcRange As Range
srcRange = ThisWorkbook.Worksheets("Main").Range("myNamedRange")
srcArray = srcRange.Value
Dim rowNr As Long
dim colNr As Long
for rowNr = 1 to UBound(srcArray,1)
if srcArray(rowNr, 9) = "testString" Then Call DeleteRowSub(srcArray, rowNr)
Next rowNr
DeleteRowSub will be a sub which will delete a given row based on the index of that row. I want to get away from that and just be able to say something like srcCollection.Remove(index) with index being the row nr.
Any help, greatly appreciated.
There's no secret to this. It's just housekeeping.
Function ReadRangeRowsToCollection(r As Range) As Collection
Dim iRow As Long
Dim iCol As Long
Dim rangeArr As Variant
Dim rowArr As Variant
Dim c As Collection
'Read range content to Variant array
rangeArr = r.Value
'Now transfer shit to collection
Set c = New Collection
For iRow = 1 To r.Rows.Count
ReDim rowArr(1 To r.Columns.Count)
For iCol = 1 To r.Columns.Count
rowArr(iCol) = rangeArr(iRow, iCol)
Next iCol
c.Add rowArr, CStr(iRow)
Next iRow
Set ReadRangeRowsToCollection = c
End Function
Example usage:
Dim c As Collection
Set c = ReadRangeRowsToCollection(Range("myNamedRange"))
c.Remove 1 ' remove first row from collection
Note: I haven't looked at edge cases; for example this will fail if the range is one cell only. Up to you to fix it.