I would like to store dictionary object in array but I am getting an error. is there any way which I can store dictionary in array
Sub aaa()
Dim arr(5)
'arr(0) = 100
Set dict_123 = CreateObject("Scripting.Dictionary")
dict_123.Add "first", 300
dict_123.Add "Second", 500
arr(0) = dict_123
End Sub
Error is Wrong number of Arguments or invalid property assignment at "arr(0) = dict_123 "
Try the following
Use Option Explicit to check variable declarations
Declare your dictionary as Object
As it is an object you need to use the set keyword when adding to array
Code:
Option Explicit
Public Sub aaa()
Dim arr(5)
Dim dict_123 As Object
Set dict_123 = CreateObject("Scripting.Dictionary")
dict_123.Add "first", 300
dict_123.Add "Second", 500
Set arr(0) = dict_123
End Sub
Edit:
As function
Option Explicit
Public Sub DoSomeThing()
Dim dict As Object
Set dict = aaa()(0)
Dim key As Variant
For Each key In dict.Keys
Debug.Print dict(key)
Next key
End Sub
Public Function aaa() As Variant
Dim arr(5)
Dim dict_123 As Object
Set dict_123 = CreateObject("Scripting.Dictionary")
dict_123.Add "first", 300
dict_123.Add "Second", 500
Set arr(0) = dict_123
aaa = arr
End Function
Related
I have dictionary. Dictionary have array of 8 elements. Can I set new value of existing array in dictionary?
My code below:
Option Explicit
Sub test()
Dim dict As Dictionary
Dim arr() As Long
Dim i As Variant
Set dict = New Dictionary
ReDim arr(1 To 8)
dict.Add "L", arr()
dict.Item("L")(3) = 500
For Each i In dict.Item("L")
Debug.Print (i)
Next
End Sub
Line dict.Item("L")(3) = 500 staying array element empty. What I am doing wrong?
Or there is only one true way?
arr(3) = 500
dict.Item("L") = arr
I made it. Trick in user function. Now it's work fine for me. All previous data are preserved without copying
Sub test()
Dim dict As New Scripting.Dictionary
Dim i As Integer, index As Integer
Dim newVal As Long
ReDim arr(1 To 8) As Long
arr(1) = 200
dict.Add "L", arr
index = 3
newVal = 500
dict("L") = updateItem(dict("L"), index, newVal)
For i = LBound(dict("L")) To UBound(dict("L"))
MsgBox dict("L")(i)
Next
End Sub
Function updateItem(ByRef currentItem As Variant, ByRef index As Integer, ByRef newVal As Long)
currentItem(index) = newVal
updateItem = currentItem
End Function
I ran into this issue once.
You can't change a single value in an array of a dictionary, you have to change the whole array
so this should work
Sub test()
Dim dict As Dictionary
Dim arr() As Long
Dim i As Variant
Set dict = New Dictionary
ReDim arr(1 To 8)
arr(3) = 500
dict.Add "L", arr()
For Each i In dict.item("L")
Debug.Print (i)
Next
End Sub
but what if you want to change a value in an already populated array in a dictionary?
simple
define a new array to hold the values in the dictionary array
Make the changes you want
Load the new array into the dictionary using the .item property
(Ex: dict.item("L") = NewArr() )
Sub test()
Dim dict As Dictionary
Dim arr() As Long
Dim i As Variant
Dim newarr() As Long
Set dict = New Dictionary
ReDim arr(1 To 8)
ReDim newarr(1 To 8)
arr(3) = 500
dict.Add "L", arr()
newarr = dict("L")
newarr(3) = 1000
dict.item("L") = newarr()
For Each i In dict.item("L")
Debug.Print (i)
Next
End Sub
My Excel raw data looks something like this:
;123456p,Roses and butterflies;;124456h,Violets are blue;
;123456d,Hello world;
Expected output:
Roses and butterflies
Violets are blue
Hello world
Trying to split the text sentences out only, for rows with multiple sentences I would need them in
separate rows, is this at all possible? Below is what I tried.
Private Sub CommandButton1_click()
Dim splitstring As String
Dim myarray() As String
splitstring = Worksheets("raw").Cells(1, 1).Value
myarray = Split(splitstring, ";")
For i = 0 To URound(myarray)
Next
End Sub
Sub raw()
End Sub
With Regular Expressions, you can populate Column B with the desired results ae below
Option Explicit
Private Sub CommandButton1_click()
Dim wSh As Worksheet
Dim rngStr As String, rngStrArr() As String, i As Long
Set wSh = Worksheets("raw")
Dim regEx As Object, mc As Object
Set regEx = CreateObject("vbscript.regexp")
regEx.Global = True
regEx.IgnoreCase = True
rngStr = Join(Application.Transpose(Application.Index(( _
wSh.Range("A1:A" & wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row)), 0, 1)))
regEx.Pattern = ",([^;]+);"
Set mc = regEx.Execute(rngStr)
rngStr = ""
For i = 0 To mc.Count - 1
rngStr = rngStr & mc(i)
Next i
rngStr = Replace(rngStr, ",", "")
rngStrArr = Split(rngStr, ";")
wSh.Range("B1").Resize(UBound(rngStrArr), 1).Value = Application.Transpose(rngStrArr)
End Sub
Try this:
Private sub SplitString()
Dim splitstring As String
Dim myarray() As String
splitstring = Cells(1, 1).Value
myarray = Split(splitstring, ",")
For i = 1 To UBound(myarray)
MsgBox (myarray(i))
Next
End Sub
I have a table, and I want to convert each row from that table in an object.
The object will have properties for each column.
I made this function:
Public Function GetProducts() As Object
Set GetProducts = New Collection
Dim p As New ProductInfo
Dim rng As Range
Dim xRow As Range
Set rng = Sheet2.Range("A2:I" & Sheet2.Range("A2").End(xlDown).Row)
For Each xRow In rng.Rows
p.Id = xRow.Cells(1, 1).Value
p.Cod = xRow.Cells(1, 2).Value
p.Name = xRow.Cells(1, 3).Value
p.productType = xRow.Cells(1, 4).Value
p.norma = xRow.Cells(1, 5).Value
p.masina = xRow.Cells(1, 6).Value
p.masinaType = xRow.Cells(1, 7).Value
p.operatori = xRow.Cells(1, 8).Value
p.sectie = xRow.Cells(1, 9).Value
GetProducts.Add Item:=p, Key:=CStr(p.Id)
Next xRow
End Function
than I tried to check the function with this Sub:
Public Sub CheckProducts()
Dim products As Collection
Dim p As ProductInfo
Set products = GetProducts()
For Each p In products
MsgBox p.Id
Next p
End Sub
The msgbox is returning always 20 (I have 20 items in my table, and last ID is 20).
When I checked the number of items in collection, I got 20, as I was expected.
Can anyone help me understand why I cannot iterate the collection and get the id of each item?
In GetProducts() you need to code:
Dim p As ProductInfo
And not:
Dim p As New ProductInfo
And then in the loop code:
Set p = New ProductInfo
Here's an example:
Data
Class - TestInfo
Private m_Id As String
Private m_Code As String
Private m_Name As String
Property Get Id() As String
Id = m_Id
End Property
Property Let Id(str As String)
m_Id = str
End Property
Property Get Code() As String
Code = m_Code
End Property
Property Let Code(str As String)
m_Code = str
End Property
Property Get Name() As String
Name = m_Name
End Property
Property Let Name(str As String)
m_Name = str
End Property
Module
Option Explicit
Sub Test()
Dim coll As Collection
Dim obj As TestInfo
Set coll = GetProducts
For Each obj In coll
MsgBox obj.Name
Next
End Sub
Public Function GetProducts() As Collection
Set GetProducts = New Collection
Dim rngData As Range
Dim lngCounter As Long
Dim obj As TestInfo '<--- do not use New here
Set rngData = ThisWorkbook.Worksheets("Sheet1").Range("A1:C7")
For lngCounter = 2 To rngData.Rows.Count
Set obj = New TestInfo '<--- use New here
obj.Id = rngData.Cells(lngCounter, 1).Value
obj.Code = rngData.Cells(lngCounter, 2).Value
obj.Name = rngData.Cells(lngCounter, 3).Value
GetProducts.Add obj
Next lngCounter
End Function
Note
And also I personally would not use this statement:
Set GetProducts = New Collection
Instead I would do:
Public Function GetProducts() As Collection
Dim coll As Collection
Dim rngData As Range
Dim lngCounter As Long
Dim obj As TestInfo
Set rngData = ThisWorkbook.Worksheets("Sheet1").Range("A1:C7")
Set coll = New Collection
For lngCounter = 2 To rngData.Rows.Count
Set obj = New TestInfo
obj.Id = rngData.Cells(lngCounter, 1).Value
obj.Code = rngData.Cells(lngCounter, 2).Value
obj.Name = rngData.Cells(lngCounter, 3).Value
coll.Add obj
Next lngCounter
Set GetProducts = coll
End Function
Why?
There's a good few Q&A on stackoverflow to read and consider:
VBA: Difference in two ways of declaring a new object? (Trying to understand why my solution works)
What's the difference between Dim As New vs Dim / Set
What is the reason for not instantiating an object at the time of declaration?
I'm working with an MS Word macro that currently calls data from an external Excel file, for a find/replace procedure in a long MS Word text. In my Excel file, Columns A has the words I want to find and Column B the words to replace with. Each change the macro performs, gets underlined and also a footnote is created on the text.
Now I need to have the macro add yet additional information about the change and also put it in the footnote. I have what I want to add, ready to go in Columns C of my Excel sheet.
More simply put: My code is already getting data from Columns A and B and putting it in the footnote. So, all I need to do now is, tell it to get the data ALSO from Column C. How do I do that?
Here's the full code:
1 standard module:
Option Explicit
Dim m_oCol1 As Collection
Dim m_oCol2 As Collection
Sub ReplaceWordsAndDefineFootnotes()
Dim clsTL As clsTerms
Dim lngIndex As Long
Set clsTL = New clsTerms
clsTL.FillFromExcel
Set m_oCol1 = New Collection
For lngIndex = 1 To clsTL.Count
'Replace each defined English word with it Hebrew equivelent.
ReplaceWords clsTL.Items(lngIndex).English, clsTL.Items(lngIndex).Hebrew
Next lngIndex
Underline_And_DefineFootnote
For lngIndex = 1 To clsTL.Count
'Replace temporary footnote text with with class defined footnote text.
FixFootnotes clsTL.Items(lngIndex).Hebrew, clsTL.Items(lngIndex).Footnote
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Function DefinedTerms() As Collection
Dim arrEng() As String
Dim arrHeb() As String
Dim lngIndex As Long
Dim oCol As Collection
Dim Term As clsTerm
'Note: Data arrays are used in this example. In practice the data could come from a Word table, Excel worksheet or other data source.
'arrEng = Split("God,heaven,earth,waters,good", ",")
'arrHeb = Split("Elohim,shamayim,aretz,mayim,tov", ",")
Set oCol = New Collection
'Put data in the collection.
For lngIndex = 0 To UBound(arrEng)
Set Term = New clsTerm
Term.English = arrEng(lngIndex)
Term.Hebrew = arrHeb(lngIndex)
Term.Footnote = arrEng(lngIndex) & ":" & arrHeb(lngIndex)
'Term.FootnoteText = varWords(lngIndex, 3) & ":" & varWords(lngIndex, 1)
oCol.Add Term, Term.English
Next lngIndex
Set DefinedTerms = oCol
lbl_Exit:
Exit Function
End Function
Sub ReplaceWords(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
'Add each term processed to a collection.
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.Range
'Replace each instance of the English word with its Hebrew equivalent.
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
Sub Underline_And_DefineFootnote()
Dim oRng As Word.Range
Dim lngIndex As Long
Dim oWord As Word.Range
Dim strWord As String
Dim lngCounter As Long
Dim lngPages As Long
With ActiveDocument
Set oRng = .Range
lngPages = .ComputeStatistics(wdStatisticPages)
For lngIndex = 1 To lngPages
Reprocess:
Set m_oCol2 = New Collection
Set oRng = oRng.GoTo(What:=wdGoToPage, Name:=lngIndex)
Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\page")
lngCounter = 1
With oRng
For Each oWord In oRng.Words
'Modify the word range to strip off white space. We want only the text portion of the word range.
strWord = UCase(Trim(oWord.Text))
oWord.Collapse wdCollapseStart
oWord.MoveEnd wdCharacter, Len(strWord)
If oWord.Characters.Last = Chr(160) Then oWord.MoveEnd wdCharacter, -1
'We need to know if the text defined by the word range is a word we want to process.
'We added all of those words to a collection during the find and replace process.
'If we try to add one of those words to the collection again then it will error and we will know _
we are dealing with a word we want to process.
On Error Resume Next
m_oCol1.Add strWord, strWord
If Err.Number <> 0 Then
On Error GoTo 0
On Error Resume Next
'We only want to underline and footnote the first instance of the term on each page.
'So add the term and key to a collection.
m_oCol2.Add strWord, strWord
oWord.Font.Underline = 1
If Err.Number = 0 Then
'There was no error so underline the term and footnote it.
'oWord.Font.Underline = 1
On Error GoTo 0
ActiveDocument.Footnotes.Add oWord, CStr(lngCounter), LCase(strWord)
lngCounter = lngCounter + 1
End If
Else
'The word wasn't a word we want to process so remove it from the collection.
m_oCol1.Remove m_oCol1.Count
End If
Next oWord
End With
'Since processing words will add footnotes, the length of the document will increase.
'I'm using this method to reenter the processing loop.
lngPages = .ComputeStatistics(wdStatisticPages)
If lngIndex < lngPages Then
lngIndex = lngIndex + 1
GoTo Reprocess
End If
Next lngIndex
End With
Set oRng = Nothing
End Sub
Sub FixFootnotes(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False 'True
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
1 of 2 class modules (clsTerm):
Option Explicit
Private msEnglish As String
Private msHebrew As String
Private msFootnote As String
Public Property Let English(ByVal sEnglish As String): msEnglish = sEnglish: End Property
Public Property Get English() As String: English = msEnglish: End Property
Public Property Let Hebrew(ByVal sHebrew As String): msHebrew = sHebrew: End Property
Public Property Get Hebrew() As String: Hebrew = msHebrew: End Property
Public Property Let Footnote(ByVal sFootnote As String): msFootnote = sFootnote: End Property
Public Property Get Footnote() As String
Footnote = msEnglish & ":" & msHebrew & " - " & msFootnote
End Property
2 of 2 class modules (clsTerms):
Option Explicit
Private mcolTerms As Collection
Private lngCount As Long
Property Get Items() As Collection
Set Items = mcolTerms
End Property
Property Set Items(oCol As Collection)
Set mcolTerms = oCol
End Property
Property Get Count() As Long
If Not mcolTerms Is Nothing Then
Count = mcolTerms.Count
Else
Count = 0
End If
End Property
Public Sub FillFromExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim vaWords As Variant
Dim cTerm As clsTerm
Dim i As Long
Const sFILE As String = "C:\Documents and Settings\Administrator\Desktop\Macro Latest Accomplishments\this_feeds_AlexfromZackMacro.xlsx"
Const xlUP As Long = -4162
Set mcolTerms = New Collection
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(sFILE, , True)
With xlWb.Worksheets(1)
'changed 2 to 3 to get column c
vaWords = .Range("A1", .Cells(.Rows.Count, 3).End(xlUP)).Value
End With
'change footnote to store column c
For i = LBound(vaWords, 1) To UBound(vaWords, 1)
Set cTerm = New clsTerm
cTerm.English = vaWords(i, 1)
cTerm.Hebrew = vaWords(i, 2)
cTerm.Footnote = vaWords(i, 3)
mcolTerms.Add cTerm
Next i
xlWb.Close False
xlApp.Quit
End Sub
Come of my variable names may have changed since the last answer, so you'll need to make it all mesh together. Change your Term class to this
Option Explicit
Private msEnglish As String
Private msHebrew As String
Private msFootnote As String
Public Property Let English(ByVal sEnglish As String): msEnglish = sEnglish: End Property
Public Property Get English() As String: English = msEnglish: End Property
Public Property Let Hebrew(ByVal sHebrew As String): msHebrew = sHebrew: End Property
Public Property Get Hebrew() As String: Hebrew = msHebrew: End Property
Public Property Let Footnote(ByVal sFootnote As String): msFootnote = sFootnote: End Property
Public Property Get Footnote() As String
Footnote = msEnglish & ":" & msHebrew & " - " & msFootnote
End Property
This makes the Let part of Footnote a place to store what you have in column C. The Get part then let's you define how you want to output the footnote. In this example, I'm reading in column C (in the next section), but when I get the footnote property, it concatenates some other terms - it's not a straight read-back of what is in column C. You can change the Get part of Footnote to make it whatever you want.
Next you need to change how the Excel file is read in.
Public Sub FillFromExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim vaWords As Variant
Dim clsTerm As cTerm
Dim i As Long
Const sFILE As String = "C:\Users\Dick\Documents\My Dropbox\Excel\wordlist.xlsx"
Const xlUP As Long = -4162
Set mcolTerms = New Collection
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(sFILE, , True)
With xlWb.Worksheets(1)
'changed 2 to 3 to get column c
vaWords = .Range("A1", .Cells(.Rows.Count, 3).End(xlUP)).Value
End With
'change footnote to store column c
For i = LBound(vaWords, 1) To UBound(vaWords, 1)
Set clsTerm = New cTerm
clsTerm.English = vaWords(i, 1)
clsTerm.Hebrew = vaWords(i, 2)
clsTerm.Footnote = vaWords(i, 3)
mcolTerms.Add clsTerm
Next i
xlWb.Close False
xlApp.Quit
End Sub
I increased the range to include Column C. Before, Footnote was a concatenation of A and B. Now it is whatever is in column C and the concatenation is done in the class, where it should be.
I didn't save the file from the last question, so some of the variables and property names may have changed. Hopefully it's clear enough that you can adapt it.
I am trying to cycle through a number of worksheets, then listbox controls within each worksheet and populate them with my code. I am using the code below:
Dim sh As Worksheet
Dim obj As OLEObject
Dim lst As MSForms.ListBox
Dim idx As Long
For idx = 1 To ThisWorkbook.Worksheets.Count
Set sh = ThisWorkbook.Worksheets(idx)
For Each obj In sh.OLEObjects
If obj.progID = "Forms.ListBox.1" Then
Set lst = obj
If (lst.Name = "lst1") Then
Call PopulateSimple(lst, "Table1")
End If
End If
Next
Next idx
This seems to fail unfortunately when I set the listbox to the object. Any idea as to how I can achieve looping through all the listboxes in different worksheets and then populating them?
Try this
Sub Sample()
Dim sh As Worksheet
Dim obj As OLEObject
Dim idx As Long
For idx = 1 To ThisWorkbook.Worksheets.Count
Set sh = ThisWorkbook.Worksheets(idx)
For Each obj In sh.OLEObjects
If TypeOf obj.Object Is MSForms.ListBox Then
If (obj.Name = "lst1") Then
Call PopulateSimple(obj, "Table1")
End If
End If
Next
Next idx
End Sub
Explanation: You are getting that error because obj is declared as OLEObject and lst as MSForms.ListBox and hence a type mismatch.
can't you use the obj in your call to PopulateSimplesince you know it is a ListBox:
Dim sh As Worksheet
Dim obj As OLEObject
Dim lst As MSForms.ListBox
Dim idx As Long
For idx = 1 To ThisWorkbook.Worksheets.Count
Set sh = ThisWorkbook.Worksheets(idx)
For Each obj In sh.OLEObjects
If obj.progID = "Forms.ListBox.1" Then
'Set lst = obj
If (obj.Name = "lst1") Then
Call PopulateSimple(obj, "Table1")
End If
End If
Next
Next idx
simplest way (moved from comment):
In my opinion you need to change
Dim lst as MSForms.ListBox
into
Dim lst as OLEObject
and that is all...