I am trying to pass an array to a collection, but I cannot seem to get the collection to populate.
Public Function CreateCol(ws As Worksheet, ary, col As collection)
Dim rng As Range, collect As collection
Dim y, skey, svalue
On Error Resume Next
'populate fund list
For y = LBound(ary) To UBound(ary)
If ary(y) <> "" Then
skey = Trim(ary(y))
svalue = WorksheetFunction.SumIf(ws.Range("A:A"), ary(y), ws.Range("P:P"))
collect.Add svalue, skey
End If
Next y
End Function
As Mat's Mug said, make sure to set the collection to an object reference. One way to do this is to put set collect = new collection before your for loop.
Related
I'm not so good with VBA, thus I'm suspecting an issue with declaring and later on using the dictionary.
I've taken a different approach. Created two functions to creat the dicts.
The for loop first is checking if the Control in userform is textbox, than is getting column number (dict_col) and checks if needs to be formatted as date (dict_for).
However each time the second dict seems to be empty... When I check content of each dict separately (before the loop), it shows correct values.
Public Function import_columns(rng As Variant) As Dictionary
Dim dict As New Dictionary
Dim i As Long
Dim count_rows As Long
Dim dict_k As String, dict_i As String
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_k = rng(i, 2)
dict_i = rng(i, 1)
dict.Add dict_k, dict_i
Next i
Set import_columns = dict
End Function
Public Function import_format(rng As Variant) As Dictionary
Dim dict_f As New Dictionary
Dim i As Long
Dim count_rows As Long
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_f(rng(i, 1)) = 0
Next i
Set import_format = dict_f
End Function
Private Sub UserForm_Initialize()
'On Error GoTo ErrorHandle
Dim wb As Workbook
Dim rng_col As Range
Dim rng_format As Range
Dim dc_value As Integer
Dim ctrl As Control
Dim ctrlType As String
Dim ctrl_name As String
Dim key As Variant
Dim dict_col As Dictionary
Dim dict_for As Dictionary
Set rng_col = Application.Union(Range("columns_mark").Columns(3), Range("columns_mark").Columns(2))
Set rng_format = Arkusz25.Range("H1").CurrentRegion
Set dict_col = import_columns(rng_col)
Set dict_for = import_format(rng_format)
'Me.Results.Enabled = False
ListBox1.RowSource = "lista"
txt_results = ListBox1.ListCount
For Each key In dict_col.Keys
'If dict_col.Exists(key) Then
Debug.Print key
Debug.Print dict_col(key)
'End If
Next key
ctrlType = "TextBox"
For Each ctrl In Results.Controls
ctrl_name = ctrl.Name
If TypeName(ctrl) = ctrlType Then
dc_value = dict_col(ctrl_name)
If dict_for.Exists(ctrl_name) Then
ctrl = Format(Val(ListBox1.List(0, dc_value - 1)), "dd.mm.yyyy")
Else
ctrl = ListBox1.List(0, dc_value - 1)
End If
ctrl.Enabled = False
End If
Next ctrl
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.
Is there a way to dump every word and their start range and end range into an array or dictionary or etc. without looping?
I already tried the following two methods and they work,
Sub test_1()
Dim wrd As Variant
Dim TxtArray() As String
Dim i As Long
For Each wrd In ActiveDocument.Range.Words
'code to add to add to array her
Next
End Sub
and
Sub test_2()
Dim TxtArray() As String
TxtArray = Split(ActiveDocument.Range.Text)
End Sub
The split method can't give me the option to register the starting and ending range positions of each word, because I may want to highlight them later on; plus when I add words to the dictionary, I eliminate the duplicate ones
Is there a way to dump the Range.Words collection without looping? I tried but it didn't work.
"when I add words to the dictionary, I eliminate the duplicate ones" - you don't have to do that: use an array of ranges as the value for the dictionary, with the word as the key.
For example:
Sub MapWords()
Dim d As New Scripting.Dictionary
Dim wrd As Variant, tmp, ub As Long, txt As String, w
Dim i As Long
For Each wrd In ActiveDocument.Range.Words
txt = Trim(wrd.Text)
If Len(txt) > 1 Then
If Not d.Exists(txt) Then
d.Add txt, GetArray(wrd)
Else
tmp = d(txt)
ub = UBound(tmp) + 1
ReDim Preserve tmp(1 To ub)
Set tmp(ub) = wrd
d(txt) = tmp
End If
End If
Next
'e.g. -
Set w = d("split")(1)
Debug.Print w.Text, w.Start, w.End
End Sub
Function GetArray(wrd)
Dim rv(1 To 1)
Set rv(1) = wrd
GetArray = rv
End Function
I have a function
Function convertToDict(arrayIp As Variant) As Object
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
For Each element In arrayIp
If dict.exists(element) Then
dict.Item(element) = dict.Item(element) + 1
Else
dict.Add element, 1
End If
Next
End Function
I tried to call this function from a sub
Dim dict As Object
varray = Range("B4:B" & finalRow - 1).Value
dict = convertToDict(varray)
But it throws error:
Run time error 450, wrong number of arguments or invalid property
what is the mistake that I have done here?
I am passing a variant and result is an Object.
Because you are dealing with Objects you need Set in both the function and the sub:
Function convertToDict(arrayIp As Variant) As Object
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
For Each element In arrayIp
If dict.exists(element) Then
dict.Item(element) = dict.Item(element) + 1
Else
dict.Add element, 1
End If
Next
Set convertToDict = dict
End Function
Sub qwerty()
Dim dict As Object
finalRow = 10
varray = Range("B4:B" & finalRow - 1).Value
Set dict = convertToDict(varray)
End Sub
Since dict is an object, you need to use Set when assigning to it. Try
Set dict = convertToDict(varray)
I have following code for filling a ListBox
Function fillData()
Dim vList As Variant
Dim ws As Worksheet: Set ws = Worksheets(BD)
With ws
If (IsEmpty(.Range("D2").Value) = False) Then
Dim lastCell As String: lastCell = "D" & .Range("D65536").End(xlUp).Row
vList = ws.Range("D2:" & lastCell).Value
Me.ListBox1.List = vList
End If
Me.ListBox1.ListIndex = -1
End With
Set vList = Nothing
Set ws = Nothing
End Function
Everything works good so far...
but when I left just one row with data this error appears:
I even printed my range with this:
MsgBox "the range is D2:" & celdaFin
this is what I got
and then the error message appears, how to do this work also with one cell??
EDIT: Solution thanks to #Jason and #tospig
Function fillData()
Dim vList As Variant
Dim ws As Worksheet: Set ws = Worksheets(BD)
Me.ListBox1.Clear
With ws
If (IsEmpty(.Range("D2").Value) = False) Then
vList = ws.Range("D2:D" & .Range("D65536").End(xlUp).Row).Value
If IsArray(vList) Then
Me.ListBox1.List = vList
Else
Me.ListBox1.AddItem (vList)
End If
End If
Me.ListBox1.ListIndex = -1
End With
Set vList = Nothing
Set ws = Nothing
End Function
Any time the variant is populated by a range with more than one value, it automatically creates a 2-D array.
The 2-D array should populate the listbox with no issues.
The array is not a 2-D array if there is only one value in the range so you may have to redim the variant manually
You may have to test the array if it is only one value
If it is only one value then
Redim vList(1 to 1, 1 to 1)
vList(1,1) = ws.Range("D2:" & lastCell).Value
The listbox should be able to take the variant at this point
For the same reasons as #Jason_Walker pointed out, if your variant is an array you can check for it using IsArray. If not, you can add it as a single item
If IsArray(vList) Then
Me.ListBox1.List = vList
Else
Me.ListBox1.AddItem = vList
End if
Update
For completeness, #Jason_Walker 's reasons:
"Any time the variant is populated by a range with more than one value, it automatically creates a 2-D array.
The 2-D array should populate the listbox with no issues.
The array is not a 2-D array if there is only one value in the range"