I want to do something extremely simple and I still can't find the solution via Google.
I want to add an item to an existing key in a VBA dictionary.
My Code:
Sub mymacro()
Set DICT = CreateObject("scripting.dictionary")
For i = 1 To 10
key = Worksheets("Sheet1").Cells(i, "D").Value
item = Worksheets("Sheet1").Cells(i, "L").Value
DICT.Add key, item
If DICT.Exists(key) Then
DICT(key).Add item '(<-- causes runtime error 424, object required)
End If
Next i
For Each i In DICT.Items: Debug.Print i: Next
End Sub
This code however is giving me a Runtime Error 424, 'Object required'
Any help is appreciated
You can store Collection objects in the Dictionary's values. This allows the storage of multiple values per key. Something like:
Option Explicit
Sub mymacro()
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim i As Long
Dim ColumnDKey As Variant
Dim ColumnLValue As Variant
Dim ColumnLValues As Collection
For i = 1 To 10
ColumnDKey = Worksheets("Sheet1").Cells(i, "D").Value
ColumnLValue = Worksheets("Sheet1").Cells(i, "L").Value
If Not dict.Exists(ColumnDKey) Then
dict.Add ColumnDKey, New Collection
End If
Set ColumnLValues = dict.Item(ColumnDKey)
ColumnLValues.Add ColumnLValue
Next i
For Each ColumnDKey In dict.Keys
Set ColumnLValues = dict.Item(ColumnDKey)
For Each ColumnLValue In ColumnLValues
Debug.Print ColumnLValue
Next
Next
End Sub
Related
Option Explicit
Public Sub consolidateList()
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
FillTableRows
End Sub
Private Sub FillTableRows()
'set up worksheet objects
Dim wkSheet As Worksheet
Dim wkBook As Workbook
Dim wkBookPath As String
Set wkBook = ThisWorkbook
wkBookPath = wkBook.Path
Set wkSheet = wkBook.Worksheets("Master")
'set up file system objects
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(wkBookPath)
Set oFiles = oFolder.Files
'set up loop
Dim checkBook As Excel.Workbook
Dim reportDict As Dictionary
Application.ScreenUpdating = False
'initial coordinates
Dim startRow As Long
Dim startColumn As Long
startColumn = 3
Dim i As Long 'tracks within the row of the sheet where information is being pulled from
Dim k As Long 'tracks the row where data is output on
Dim j As Long 'tracks within the row of the sheet where the data is output on
Dim Key As Variant
j = 1
k = wkSheet.Range("a65536").End(xlUp).Row + 1
Dim l As Long
'look t Set checkBook = Workbooks.Open(oFile.Path)hrough folder and then save it to temp memory
On Error GoTo debuger
For Each oFile In oFiles
startRow = 8
'is it not the master sheet? check for duplicate entries
'oFile.name is the name of the file being scanned
'is it an excel file?
If Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xls" Or Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xlsx" Then
Set checkBook = Workbooks.Open(oFile.Path)
For l = startRow To 600
If Not (IsEmpty(Cells(startRow, startColumn))) Then
'if it is, time do some calculations
Set reportDict = New Dictionary
'add items of the payment
For i = 0 To 33
If Not IsEmpty(Cells(startRow, startColumn + i)) Then
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
End If
Next i
For i = startRow To 0 Step -1
If Not IsEmpty(Cells(i, startColumn - 1)) Then
reportDict.Add "Consumer Name", Cells(i, startColumn - 1)
Exit For
End If
Next i
'key is added
For Each Key In reportDict
'wkSheet.Cells(k, j) = reportDict.Item(Key)
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
MsgBox (myInsert)
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
j = j + 1
Next Key
wkSheet.Cells(k, j) = wkSheet.Cells(k, 9) / 4
wkSheet.Cells(k, j + 1) = oFile.Name
'
k = k + 1
' Set reportDict = Nothing
j = 1
Else
l = l + 1
End If
startRow = startRow + 1
Next l
checkBook.Close
End If
' Exit For
Next oFile
Exit Sub
debuger:
MsgBox ("Error on: " & Err.Source & " in file " & oFile.Name & ", error is " & Err.Description)
End Sub
Sub DeleteTableRows(ByRef Table As ListObject)
On Error Resume Next
'~~> Clear Header Row `IF` it exists
Table.DataBodyRange.ClearContents
'~~> Delete all the other rows `IF `they exist
Table.DataBodyRange.Offset(1, 0).Resize(Table.DataBodyRange.Rows.count - 1, _
Table.DataBodyRange.Columns.count).Rows.Delete
On Error GoTo 0
End Sub
Greetings. The above code consolidates a folder of data that's held on excel spreadsheets into one master excel spreadsheet. The goal is to run a macro on Excel Spreadsheet named master on the worksheet named master which opens up other excel workbooks in the folder, takes the information, and puts it into a table in the worksheet "master". After which point, it becomes easy to see the information; so instead of it being held on hundreds of worksheets, the records are held on one worksheet.
The code uses a dictionary (reportDict) to temporarily store the information that is needed from the individual workbooks. The goal then is to take that information and place it in the master table at the bottom row, and then obviously add a new row either after a successful placement or before an attempted placement of data.
The code fails at the following line:
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
The failure description is "object or with variable not set" and so the issue is with the reportDict.Item(Key). My guess is that somehow VBA is not recognizing the dictionary item as stable, but I don't know how to correct this. Eventually the goal is to have code which does:
for each key in reportDict
- place the item which is mapped to the key at a unique row,column in the master table
- expand the table to accomodate necessary data
next key
Implicit default member calls are plaguing your code all over.
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
That's implicitly accessing Range.[_Default] off whatever worksheet is currently the ActiveSheet (did you mean that to be wkSheet.Cells?), to get the Key - since the Key parameter is a String, Range.[_Default] is implicitly coerced into one, and you have a string key. The actual dictionary item at that key though, isn't as lucky.
Here's a MCVE:
Public Sub Test()
Dim d As Dictionary
Set d = New Dictionary
d.Add "A1", Cells(1, 1)
Debug.Print IsObject(d("A1"))
End Sub
This procedure prints True to the debug pane (Ctrl+G): what you're storing in your dictionary isn't a bunch of string values, but a bunch of Range object references.
So when you do this:
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
You might as well have declared myInsert As Range, for it is one.
This is where things get interesting:
MsgBox (myInsert)
Nevermind the superfluous parentheses that force-evaluate the object's default member and pass it ByVal to the MsgBox function - here you're implicitly converting Range.[_Default] into a String. That probably works.
So why is this failing then?
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
Normally, it wouldn't. VBA would happily do this:
wkSheet.ListObjects(1).DataBodyRange.Cells(2, 1).[_Default] = reportDict.Item(Key).[_Default]
And write the value in the DataBodyRange of the ListObject at the specified location.
I think that's all just red herring. Write explicit code: if you mean to store the Value of a cell, store the Value of a cell. If you mean to assign the Value of a cell, assign the Value of a cell.
I can't replicate error 91 with this setup.
This, however:
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
...is also force-evaluating a ListObject's default member - so DeleteTableRows isn't receiving a ListObject, it's getting a String that contains the name of the object you've just dereferenced... but DeleteTableRows takes a ListObject parameter, so there's no way that code can even get to run FillTableRows - it has to blow up with a type mismatch before DeleteTableRows even gets to enter. In fact, it's a compile-time error.
So this is a rather long answer that doesn't get to the reason for error 91 on that specific line (I can't reproduce it), but highlights a metric ton of serious problems with your code that very likely are related to this error you're getting. Hope it helps.
You need to iterate through the dictionary's Keys collection.
dim k as variant, myInsert As Variant
for each k in reportDict.keys
debug.print reportDict.Item(k)
next k
I have developed the following two subs which create and remove a collection of checkboxes next to a listobject. Each distinct ID in the listobject gets a checkbox. Like this I can approve the listobject entries.
The code is the follwing:
Public CBcollection As Collection
Public CTRLcollection As Collection
Sub create_chbx()
If Approval.CBcollection Is Nothing Then
Dim i As Integer
Dim tbl As ListObject
Dim CTRL As Excel.OLEObject
Dim CB As MSForms.CheckBox
Dim sht As Worksheet
Dim L As Double, T As Double, H As Double, W As Double
Dim rng As Range
Dim ID As Long, oldID As Long
Set CBcollection = New Collection
Set CTRLcollection = New Collection
Set sht = ActiveSheet
Set tbl = sht.ListObjects("ApprovalTBL")
Set rng = tbl.Range(2, 1).Offset(0, -1)
W = 10
H = 10
L = rng.Left + rng.Width / 2 - W / 2
T = rng.Top + rng.Height / 2 - H / 2
For i = 1 To tbl.ListRows.count
ID = tbl.Range(i + 1, 1).Value
If Not (ID = oldID) Then
Set CTRL = sht.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=L, Top:=T, Width:=W, Height:=H)
Set CB = CTRL.Object
CBcollection.Add Item:=CB
CTRLcollection.Add Item:=CTRL
End If
Set rng = rng.Offset(1, 0)
T = rng.Top + rng.Height / 2 - H / 2
oldID = ID
Next i
End If
End Sub
Sub remove_chbx()
If Not Approval.CBcollection Is Nothing Then
With Approval.CBcollection ' Approval is the module name
While .count > 0
.Remove (.count)
Wend
End With
With Approval.CTRLcollection
While .count > 0
.Item(.count).Delete
.Remove (.count)
Wend
End With
Set Approval.CBcollection = Nothing
Set Approval.CTRLcollection = Nothing
End If
End Sub
This all works pretty well. No double checkboxes and no errors if there are no checkboxes. I am developing an approval scheme were I need to develop and test other modules. If I now run this sub:
Sub IdoStupidStuff()
Dim i As Integer
Dim Im As Image
i = 1
Set Im = i
End Sub
It will give me an error. If I then try to run one of my checkbox subs they will not work properly anymore. The collection is deleted by the error and I am no longer able to access the collections. Why does this happen and am I able to counter act this other then just not causing errors? Is there a better way to implement such a system were loss of collections is not an issue?
You could wrap the Collection object in a Property and let it handle the object creation:
Private mCollection As Collection
Public Property Get TheCollection() As Collection
If mCollection Is Nothing Then Set mCollection = New Collection
Set TheCollection = mCollection
End Property
To call it:
TheCollection.Count
Try On Error Resume Next before the line that causes the error. It will skip the problem and your vairables will still be available.
However this will not solve your error. Try to make a seperate hidden sheet in your workbook to store your global variables so they won't go missing.
f.ex.:
Private Sub CreateSheet()
Dim ws As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Global"
.Worksheets("Global").Visible = False
End With
End Sub
I was trying to use dictionary to lookup value in column F
with key in column C.
But after the result dont return like I want. It show "0"
Scenario:
1. key in column C will have mutliple same value
2. I want to sum up all the value in column F based on key and return to "RAW" Range("C2")
"Sheet2"
"RAW"
Please help me.
Thanks in advance.
Here my code.
Option Explicit
Private Lrow As Long
Private oDict As Object
Private Sub CreateDict()
Dim arrValues As Variant, oKey As Variant, oValue As Variant, i As Long
'Find Master Item List Japan
Dim Master As Workbook
Dim t As Workbook
For Each t In Workbooks
If Left(t.Name, 16) = "Master Item List" Then
Set Master = Workbooks(t.Name)
End If
Next t
Set oDict = Nothing
If oDict Is Nothing Then
Set oDict = New Scripting.Dictionary
End If
' Add items to the dictionary
' Load values of used range to memory
arrValues = Master.Sheets("Sheet2").UsedRange.Value
' Assuming the Key is on first column and Value is on next
For i = 2 To UBound(arrValues)
oKey = arrValues(i, 3)
oValue = arrValues(i, 6)
If Len(oKey) > 0 Then
If oDict.Exists(oKey) Then
' Append Value to existing key
oDict(oKey) = oDict(oKey) + oValue
Else
' Add Key and value
oDict(oKey) = oValue
End If
End If
Next i
End Sub
Function GetList(ByVal oRange As Range) As Variant
If oDict Is Nothing Then CreateDict
' Static oDict As Scripting.Dictionary 'precerved between calls
If oDict.Exists(oRange.Value) Then
GetList = oDict.Item(oRange.Value)
' Else
' GetList = 0
End If
End Function
Just For Reference.
This is code I use in other workbook and working nicely
Option Explicit
Private lRow As Long
Private oDict As Object
Private Sub CreateDict()
Dim arrValues As Variant, oKey As Variant, oValue As Variant, i As Long
'Find Master Item List Japan
Dim Master As Workbook
Dim t As Workbook
For Each t In Workbooks
If Left(t.Name, 16) = "Master Item List" Then
Set Master = Workbooks(t.Name)
End If
Next t
Set oDict = Nothing
If oDict Is Nothing Then
Set oDict = New Scripting.Dictionary
End If
' Add items to the dictionary
' Load values of used range to memory
arrValues = Master.Sheets("Sheet2").UsedRange.Value
' Assuming the Key is on first column and Value is on next
For i = 1 To UBound(arrValues)
oKey = arrValues(i, 3)
oValue = arrValues(i, 6)
If Len(oKey) > 0 Then
If oDict.Exists(oKey) Then
' Append Value to existing key
oDict.Item(oKey) = oDict.Item(oKey)
Else
' Add Key and value
oDict.Add oKey, oValue
End If
End If
Next
End Sub
Function GetList(ByVal oRange As Range) As Long
If oDict Is Nothing Then CreateDict
' Static oDict As Scripting.Dictionary 'precerved between calls
If oDict.Exists(oRange.Value) Then
GetList = oDict.Item(oRange.Value)
Else
GetList = 0
End If
End Function
EDIT #1:
Based on #YowE3k comment I try execute the GetFile Function and got the result as picture below.
Not very sure why last one return with 0
Can this is because it have same key already in my dictionary history because in other workbook I use same key.
I'm trying to create a mapping for data cleaning using vba dictionary. I store a range of values of country codes like FR, BE, NL as keys and their offset values as items: France, Belgium, Netherlands... When I run a test and try to retrieve the values using the strings as key, it throws run time error 451 'did not return object' Can anyone tell me what could be the problem?
Sub getthisdone()
'Dim dict As scripting.dictionary
Dim ws As Worksheet
Dim lastRow As Long
Dim key As String, dictItem As String
Dim i As Long
Set ws = ThisWorkbook.Worksheets("Country mapping")
Set dict = CreateObject("Scripting.Dictionary")
lastRow = ws.Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = 2 To 8 'lastRow
key = ws.Cells(i, 1).Text
dictItem = ws.Cells(i, 2).Text
With dict
.Add key, dictItem
End With
Next i
MsgBox dict.items("FR") '<---- Error happens here, why?
End Sub
.Item not .Items
MsgBox dict.Item("FR")
If you click Project → References, tick "Microsoft Scripting Runtime" and change the CreateObject line to:
Dim dict As Scripting.Dictionary: Set dict = New Scripting.Dictionary
You will get early binding auto-completion and avoid typos like this.
I am new to VBA Coding.I have an userform which retrieves the value from excel sheet.There is a combobox which retrieves the value.But i want to change the combobox value & save it in excel.....
Image for Data in Excel
Dim temp As String
Dim findid As String
Dim lkrange As Range
Set lkrange = Sheet6.Range("A:D")
findid = TextBox1.Value
On Error Resume Next
temp = Application.WorksheetFunction.Vlookup(findid, lkrange, 1, 0)
If Err.Number <> 0 Then
MsgBox "ID not found"
Else
MsgBox "ID found"
Label5.Caption = Application.WorksheetFunction.Vlookup(findid, lkrange, 2, 0)
Label6.Caption = Application.WorksheetFunction.Vlookup(findid, lkrange, 3, 0)
ComboBox1.Value = Application.WorksheetFunction.Vlookup(findid, lkrange, 4, 0)
End If
End Sub
Private Sub CommandButton2_Click()
Dim fid As String
Dim rowc As Integer
Dim rowv As Integer
fid = TextBox1.Value
rowc = Application.WorksheetFunction.Match(fid, Range("A:A"), 0)
rowv = rowc - 1
Cells(rowv, 4).Values = marktable.ComboBox1.Value
End Sub
you could try the following
Option Explicit
Private Sub CommandButton1_Click()
Dim lkrange As Range
Dim rng As Range
Set lkrange = ThisWorkbook.Sheets("Sheet6").Range("A:A")
With Me
Set rng = MyMatch(.TextBox1.Value, lkrange)
If rng Is Nothing Then
MsgBox "ID not found"
Else
MsgBox "ID found"
.Label5.Caption = rng.Offset(0, 1)
.Label6.Caption = rng.Offset(0, 2)
.ComboBox1.Text = rng.Offset(0, 3)
End If
End With
End Sub
Private Sub CommandButton2_Click()
Dim lkrange As Range
Dim rng As Range
Set lkrange = ThisWorkbook.Sheets("Sheet6").Range("A:A")
With Me
Set rng = MyMatch(.TextBox1.Value, lkrange)
If Not rng Is Nothing Then rng.Offset(0, 3).Value = .ComboBox1.Text
End With
End Sub
Private Function MyMatch(val As Variant, rng As Range, Optional matchType As Variant) As Range
Dim row As Long
If IsMissing(matchType) Then matchType = 0
On Error Resume Next
row = Application.WorksheetFunction.Match(val, rng, matchType)
If Err = 0 Then Set MyMatch = rng.Parent.Cells(rng.Rows(row).row, rng.Column)
End Function
there were some errors:
Sheet6.Range("A:D") is not vaild
if you want to point to a sheet named "Sheet6" belonging to the Workbook where the macro resides, then you have to use ThisWorkbook.Sheets("Sheet6").Range("A:A")
Cells(...,...).Values =... is not valid
you must use Cells(...,...).Value =
but I think the following suggestions are more important:
Always use Option Explicit statement at the very beginning of every module
this will force you to explicitly declare each and every variable, but then it'll save you lots of time in debugging process
avoid/limit the use of On Error Resume Next statement
and, when used, make sure to have it followed as soon as possible by the "On Error GoTo 0" one. that way you have constant control on whether an error occurs and where
I confined it in a "wrapper" function (MyMatch()) only.
Always specify "full" references when pointing to a range
I mean, Cells(..,..) implictly points to the active sheet cells, which may not always be the one you'd want to point to.