Create Array from a Collection

[Greg Maxey]

I am trying to build a list of ContentControls in a document by unique
Titles. That is if there are two or more CCs with the same title I only
want to list it once. I am using a Collection and the key method to ensure
the CCs title is only added one time. Then I am stepping through the
members of the collection one at a time to add them to an Array. Is there a
more direct method to convert a collection to an array?

Sub ScratchMacro()
Dim oCC As ContentControl
Dim oColl As Collection
Set oColl = New Collection
Dim i As Long
Dim tempList() As String
For Each oCC In ActiveDocument.ContentControls
If oCC.Title <> "" Then
Select Case oCC.Type
Case Is = 1, 3, 4, 6 'CCs of type text, dropdown, combobox, and date
only
'Use error on duplicate key to ensure only unique titles are added.
On Error Resume Next
oColl.Add oCC.Title, oCC.Title
On Error GoTo 0
Case Else
'Do Nothing
End Select
End If
Next
If oColl.Count > 0 Then
'Create array from collection.
ReDim tempList(oColl.Count - 1)
'Is there a more direct method to populate an array with collection
elements?
For i = 0 To oColl.Count - 1
tempList(i) = oColl(i + 1)
Next
Else
ReDim tempList(0)
tempList(0) = "****Empty List****"
End If
'Sort array alphabetically
WordBasic.SortArray tempList
End Sub

 

[Steve Yandl]

Greg,

Have you ever worked with the "Scripting.Dictionary" object. It is a bit
similar to using a collection but there is a keys method that delivers an
array of the keys you've added (and also an Items method that delivers an
array of the items. Keys are unique and there is an 'Exists' method that
allows a quick check to see if the key is already present in the dictionary
object you're adding keys and items to.

Below is an example I recently did for someone who wanted to identify and
build a count of all the words in a short story and then present them
alphabetically in a new document. I didn't put many comments in the sub but
I think it will probably be easy enough to follow what I did with the
scripting.dictionary object.


Steve Yandl

_____________________________

Sub AlphaSortCountII()
Const adVarChar = 200
Const MaxCharacters = 255

Dim strWord As Variant
Dim strOutput As String
Dim wordArray()
Dim intChr1 As Integer
Dim intChrX As Integer
Dim intChrY As Integer

strOutput = ""

Set objDic = CreateObject("Scripting.Dictionary")

For Each strWord In ActiveDocument.Words
strWord = LCase(strWord)
strWord = Trim(strWord)
strWord = Replace(strWord, Chr(34), "")
strWord = Replace(strWord, Chr(39), "")
intChr1 = Asc(Left(strWord, 1))
intChrX = Asc(Right(strWord, 1))
If intChrX < 97 Or intChrX > 122 Then
strWord = Left(strWord, Len(strWord) - 1)
End If
If Len(strWord) = 1 Then
If strWord = "i" Or strWord = "a" Then
Else
strWord = ""
End If
End If
strWord = Trim(strWord)
If Len(strWord) > 1 Then
intChrY = Asc(Right(strWord, 1))
If intChrY = 146 Then
strWord = Left(strWord, Len(strWord) - 1)
End If
End If
If Len(strWord) > 0 Then
If intChr1 > 96 And intChr1 < 123 Then
If objDic.Exists(strWord) Then
objDic.Item(strWord) = objDic.Item(strWord) + 1
Else
objDic.Add strWord, 1
End If
End If
End If
Next strWord

If objDic.Count > 0 Then
wordArray = objDic.Keys
End If

Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "myWords", adVarChar, MaxCharacters
DataList.Open

For m = 0 To UBound(wordArray)
DataList.AddNew
DataList("myWords") = wordArray(m) _
& " (" & CStr(objDic.Item(wordArray(m))) & ")"
DataList.Update
Next m

DataList.Sort = "myWords"

DataList.MoveFirst
Do Until DataList.EOF
strOutput = strOutput & DataList.Fields.Item("myWords") & vbCrLf
DataList.MoveNext
Loop

Set objDoc2 = Documents.Add
Set objSelection = Application.Selection
objSelection.TypeText strOutput

Set objDic = Nothing
Set DataList = Nothing
End Sub

 

[Steve Yandl]

Greg,

Just to cut through some of the extra fluff in my sub that doesn't pertain
to your issue, here would be the key lines using your variable names.


Set objDic = CreateObject("Scripting.Dictionary")

If Not objDic.Exists(occ.Title) Then
objDic.Add occ.Title, occ.Title
End If

If objDic.Count > 0 Then
tempList = objDic.Keys
End If

Set objDic = Nothing

 

[Greg Maxey]

Steve,

I have never used that before. Thanks for posting. I will look at it now.

 

[Greg Maxey]

Steven,

Very nice. Unfortunately, as the example below shows, WordBasic.SortArray
takes an array of Strings :-(

I saw and tested your sort and it certainly works, but in the case in hand I
expect it will be just as efficient to stay with the collection and then a
simple SortArray.

I will definately file this exchange away for future reference. Thank you!!

Sub Test()
Dim objDic
Dim pList() As String
Dim tempList '() As String
Dim i As Long
pList = Split("Z>A>F>G>G>A>R>T>A>T", ">")
Set objDic = CreateObject("Scripting.Dictionary")
For i = LBound(pList) To UBound(pList)
If Not objDic.Exists(pList(i)) Then
objDic.Add pList(i), pList(i)
End If
Next i
If objDic.Count > 0 Then
tempList = objDic.Keys
End If
WordBasic.SortArray tempList
For i = LBound(tempList) To UBound(tempList)
MsgBox tempList(i)
Next
Set objDic = Nothing
End Sub

 

[Steve Yandl]

Greg,

Thanks for your comments.

Most of what I do in the programming arena is with scripts (vbs files). I
regularly visit this forum and those for Excel and Access to discover
tidbits that I can incorporate ("steal") but every once in a while there are
elements from the script world that can increase efficiency for those
working with VBA. I generally don't jump in when the script component that
can help is the Scripting.FileSystemObject, because there seems to be a
familiarity with those tools in the group. In the case of the dictionary
object, that isn't always the case.

On a different note, thanks for reminding me (by example) that there is a
WordBasic method for sorting arrays.


Steve Yandl