I'm writing an acronym generator and have about 5,000 known terms I'd like to add to a collection or dictionary object. Unfortunately VBA limits how many lines of code can appear in a single subroutine, so I receive an error if I try to add the terms individually. Is there a way to add numerous 2-D values to a collection or dictionary using a single line of code?
Thx in advance
I tried adding the 2-D values using individual lines of code and received a compile error: "Procedure too large."
Yes, you can load your data to a Collection with a single line of code (and with a Module of supporting code) by storing your acronym data in the 'custom XML' within the Document. In summary, the steps are:
In detail
Add a standard Module called 'DataStore' (you can rename it later) and add the following code to it. The code is commented for an explanation.
Option Explicit
Option Private Module
Private Const msDATA_NAME As String = "MyHiddenData"
Private Const msITEM As String = "Item"
Private Const msNAME As String = "Name"
Private Const msVALUE As String = "Value"
'***************************************
'* PROCEDURES FOR THE DEVELOPER TO RUN *
'***************************************
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Load data to this Document's custom XML (ie a 'CustomXMLPart')
' 1. In this Document, create a 2-column Table with the 'key' in the first column and the 'value' in the second column
' 2. Put the cursor in the Table
' 3. Run this method ... fix any errors with the data in the Table unless you see "Successfully loaded data ..."
' ---------------------------------------------------------------------------------------------------------------------
Private Sub LoadData()
Dim sXML As String, tbl As Table
sXML = "<" & msDATA_NAME & ">" & vbNewLine
Set tbl = Selection.Tables(1)
Dim i As Long, sKey As String, sValue As String
For i = 1 To tbl.Rows.Count
sKey = SwapSpecials(tbl.Cell(i, 1).Range.Text, True)
sValue = SwapSpecials(tbl.Cell(i, 2).Range.Text, True)
sXML = sXML & " <" & msITEM & " " & msNAME & "=""" & sKey & """ " & msVALUE & "=""" & sValue & """/>" & vbNewLine
Next i
sXML = sXML & "</" & msDATA_NAME & ">" & vbNewLine
DeleteExisting
ThisDocument.CustomXMLParts.Add sXML
MsgBox "Successfully loaded data as CustomXMLPart '" & msDATA_NAME & "'"
End Sub
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: If you want to delete any custom XML data, run this method and select which CustomXMLPart(s) to delete
' ---------------------------------------------------------------------------------------------------------------------
Private Sub DeleteCustomXMLParts()
Dim cxp As CustomXMLPart, i As Long, bFound As Boolean
For i = ThisDocument.CustomXMLParts.Count To 1 Step -1
Set cxp = ThisDocument.CustomXMLParts(i)
If Not cxp.BuiltIn Then
bFound = True
If MsgBox("Do you want to delete CustomXMLPart '" & cxp.DocumentElement.BaseName & "'?", vbYesNo) = vbYes Then
cxp.Delete
End If
End If
Next i
If Not bFound Then
MsgBox "Found no CustomXMLParts to delete"
End If
End Sub
'***********************************************************
'* PUBLIC PROCEDURES TO BE CALLED BY CODE IN OTHER MODULES *
'***********************************************************
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Get all of the load data as a Collection
' Parameter outsColl (Collection): If successful, will be updated with the data, otherwise will be an empty Collection
' Returns (Boolean): True if successful, False otherwise
' ---------------------------------------------------------------------------------------------------------------------
Public Function TryGetAllData(ByRef outsColl As Collection) As Boolean
Dim cxp As CustomXMLPart
Set outsColl = New Collection
If TryGetPart(msDATA_NAME, cxp) Then
Dim cxn As CustomXMLNode
For Each cxn In cxp.SelectNodes("/" & msDATA_NAME & "/*")
outsColl.Add SwapSpecials(GetAttributeValue(cxn, msVALUE), False), SwapSpecials(GetAttributeValue(cxn, msNAME), False)
Next cxn
TryGetAllData = True
End If
End Function
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Get the value for a given key
' Parameter sKey (String): The key
' Parameter outsValue (String): If successful, will be updated with the value associated with the key, otherwise an
' empty String
' Returns (Boolean): True if successful, False otherwise
' ---------------------------------------------------------------------------------------------------------------------
Public Function TryGetData(sKey As String, ByRef outsValue As String) As Boolean
Dim cxp As CustomXMLPart
If TryGetPart(msDATA_NAME, cxp) Then
TryGetData = TryGetNodeText(cxp, sKey, outsValue)
End If
End Function
'*****************************
'* PRIVATE HELPER PROCEDURES *
'*****************************
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Delete the loaded XML data, if present
' ---------------------------------------------------------------------------------------------------------------------
Private Sub DeleteExisting()
Dim cxp As CustomXMLPart, i As Long
For i = ThisDocument.CustomXMLParts.Count To 1 Step -1
Set cxp = ThisDocument.CustomXMLParts(i)
If Not cxp.BuiltIn Then
If cxp.DocumentElement.BaseName = msDATA_NAME Then
cxp.Delete
End If
End If
Next i
End Sub
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Get a CustomXMLPart
' Parameter sPartName (String): The name of the CustomXMLPart
' Parameter outCxp (CustomXMLPart): If successful, will be updated with the CustomXMLPart object, otherwise Nothing
' Returns (Boolean): True if successful, False otherwise
' ---------------------------------------------------------------------------------------------------------------------
Private Function TryGetPart(sPartName As String, ByRef outCxp As CustomXMLPart) As Boolean
Dim cxp As CustomXMLPart
For Each cxp In ThisDocument.CustomXMLParts
If cxp.DocumentElement.BaseName = sPartName Then
Set outCxp = cxp
TryGetPart = True
Exit Function
End If
Next cxp
End Function
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Get the text of a CustomXMLNode
' Parameter cxp (CustomXMLPart): The CustomXMLPart that the CustomXMLNode is within
' Parameter sNodeName (String): The name of the CustomXMLNode
' Parameter outsText (String): If successful, will be updated with the text of the CustomXMLNode, otherwise an empty
' String
' Returns (Boolean): True if successful, False otherwise
' ---------------------------------------------------------------------------------------------------------------------
Private Function TryGetNodeText(cxp As CustomXMLPart, sNodeName As String, ByRef outsText As String) As Boolean
Dim sXPath As String
If InStr(1, sNodeName, "'") = 0 Then
sXPath = "//" & msITEM & "[@" & msNAME & "='" & sNodeName & "']"
Else
' use the XPath 'concat' function to work around the fact that the path is both enclosed in, and contains,
' apostrophes
Dim sConcat As String
sConcat = "concat('" & Join(Split(sNodeName, "'"), "', ""'"", '") & "')"
sXPath = "//" & msITEM & "[@" & msNAME & "=" & sConcat & "]"
End If
On Error GoTo errExit
outsText = GetAttributeValue(cxp.SelectSingleNode(sXPath), msVALUE)
TryGetNodeText = True
Exit Function
errExit:
End Function
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Swap 'special characters'
' Parameter sText (String): The input String
' Parameter bLoading (Boolean): If True, the end-of-cell characters for Word Tables are removed and characters that are
' 'special' in XML are escaped; if False, escaped characters are replaced with the 'original' character
' Returns (String): The 'swapped' String
' ---------------------------------------------------------------------------------------------------------------------
Private Function SwapSpecials(sText As String, bLoading As Boolean) As String
If bLoading Then
SwapSpecials = Replace(sText, Chr$(13) & Chr$(7), vbNullString)
SwapSpecials = Replace(SwapSpecials, "&", "&")
SwapSpecials = Replace(SwapSpecials, """", """)
SwapSpecials = Replace(SwapSpecials, "'", "'")
SwapSpecials = Replace(SwapSpecials, "<", "<")
SwapSpecials = Replace(SwapSpecials, ">", ">")
Else
SwapSpecials = Replace(sText, ">", ">")
SwapSpecials = Replace(SwapSpecials, "<", "<")
SwapSpecials = Replace(SwapSpecials, "'", "'")
SwapSpecials = Replace(SwapSpecials, """, """")
SwapSpecials = Replace(SwapSpecials, "&", "&")
End If
End Function
' ---------------------------------------------------------------------------------------------------------------------
' Purpose: Get the value of an Attribute from a CustomXMLNode
' Parameter cxn (CustomXMLNode): The CustomXMLNode
' Parameter sAttrName (String): The name of the Attribute
' Returns (String): The value of the Attrubute
' ---------------------------------------------------------------------------------------------------------------------
Private Function GetAttributeValue(cxn As CustomXMLNode, sAttrName As String) As String
Dim attr As CustomXMLNode
For Each attr In cxn.Attributes
If attr.BaseName = sAttrName Then
GetAttributeValue = attr.Text
Exit Function
End If
Next attr
End Function
In the same document, add a 2-column Table where the first column contains the 'key' (in your case this is the term) and the second column contains the value (in your case this is the acronym). As this is going to be loaded into a Collection then the each 'key' must be unique (not case sensitive ie so two keys called "key" and "Key" are not allowed)
Put the cursor / caret into the Table and run DataStore.LoadData, ensure you see the "Successfully loaded data ..." message (otherwise fix any reported problems).
You might want to run the below test methods first, however, you can now delete the table and save your document ... it now has the XML stored within it. If you need to update the terms / acronyms again in the future, you can just temporarily add a table, run DataStore.LoadData then delete the Table.
The single line being
DataStore.TryGetAllData collOfAcronyms
... where collOfAcronyms is your Collection, though in reality you will want to use this in an If statement as follows in the TestAll test method.
The test methods are (TestAll is an example of loading all terms/acronyms into a single Collection; TestIndividual is an example of loading a single acronym from a term on-the-fly):
Sub TestAll()
Dim collOfAcronyms As Collection
If DataStore.TryGetAllData(collOfAcronyms) Then
Dim tbl As Table, i As Long, sText As String
Set tbl = Selection.Tables(1)
For i = 1 To tbl.Rows.Count
sText = Replace(tbl.Cell(i, 1).Range.Text, Chr$(13) & Chr$(7), vbNullString)
Debug.Print Now, "'" & sText & "' = '" & collOfAcronyms.Item(sText) & "'"
Next i
Else
Debug.Print Now, "Failed"
End If
End Sub
Sub TestIndividual()
Dim tbl As Table, i As Long, sText As String
Set tbl = Selection.Tables(1)
Dim sAcronym As String
For i = 1 To tbl.Rows.Count
sText = Replace(tbl.Cell(i, 1).Range.Text, Chr$(13) & Chr$(7), vbNullString)
If DataStore.TryGetData(sText, sAcronym) Then
Debug.Print Now, "'" & sText & "' = '" & sAcronym & "'"
Else
Debug.Print Now, "'" & sText & "' ... failed"
End If
Next i
End Sub
... obviously these will only work while the Table is still in the document, normal usage will be, for the Collection ... load the data
Dim collOfAcronyms As Collection
If DataStore.TryGetAllData(collOfAcronyms) Then
' successfully got all of the acronyms ... use them
Else
' failed to get the acronyms
End If
... then use the Collection as you would any other eg
sAcronym = collOfAcronyms.Item(sTerm)
And usage to get individual acronyms (ie without loading all terms and acronyms into a Collection first) will be eg
If DataStore.TryGetData(sTerm, sAcronym) Then
' successfully got the acronym ... use it
Else
' failed to get the acronym (no such term?)
End If
This is what MS specify about a module capacity:
There is no specific limit on the number of lines in a module. The total size of a code module should not exceed 64K (65536 characters) - beyond that, code will become unstable.
Verbosely:
How many lines of code can one module in VBA editor contain ... (https://answers.microsoft.com/en-us/msoffice/forum/all/how-many-lines-of-code-can-one-module-in-vba/7352d440-4181-4a3d-b685-be50119eed87)
This result that capacity is not depending on the arrays dictionaries or other objects methods of how they are filled, but only the code text length, with which you want to fulfill the job.
BigBen suggestion is a simple way to get the result you need. The external file than can be loaded with one of the filereader methods to a suitable object.
A workaround
Define a global variable which will be the storage of the large data.
Start to fill the data in Module1. At the end of the window capacity call another Sub from another module e.g. Module2 and continue the fill operation on that program segment. And so on.
Public Store as Dictionary
Public Sub FillCode1()
'Here are the instructions to fill Store object with the data part1.
FillCode2
End Sub 'FillCode1
In a new Module
Public Sub FillCode2()
'Here are the instructions to fill Store object with the data part2.
FillCode3
End Sub 'FillCode2
In a new Module
Public Sub FillCode3()
' The end of the fill instructions with data part3 and the processing code.
End Sub
