My Excel VBA takes ~300 XLS files and grabs 8 cells to deposit into their own row. (Office11) I have several subs and functions that use location constants for the sourceData and destination locations. Grand Total I have 23 constant locations with Column numbers, cell locations.
Question: Any suggestions on how to clean this up for readability and keeping constants all in one location? I was trying to avoid public variables but not sure of a better method. How do you do Arrays containing constant values?
partial example,Public pstrQLocations(1 To 8) As String
pstrQLocations(1) = "B7"
pstrQLocations(2) = "B6"
pstrQLocations(3) = "B5"
pstrQLocations(4) = "B8"
pstrQLocations(5) = "A3"
pstrQLocations(6) = "C8"
You can store your Constants in a Collection. The advantage is, that you can give your elements names.
Option Explicit
Dim pstrQLocations As Collection
Private Sub initializeConstants()
Set pstrQLocations = New Collection
pstrQLocations.Add "B7", "Title"
pstrQLocations.Add "B6", "User"
End Sub
Private Sub showConstants()
initializeConstants
Debug.Print Me.Range(pstrQLocations("Title")).Value
Debug.Print Me.Range(pstrQLocations("User")).Value
End Sub
3D Version:
Option Explicit
Dim pstrQLocations As Collection
Private Sub initializeConstants()
Dim title As New Collection
Set pstrQLocations = New Collection
title.Add "B7", "source"
title.Add "A6", "destination"
pstrQLocations.Add title, "Title"
End Sub
Private Sub showConstants()
Dim y As Collection
initializeConstants
Debug.Print pstrQLocations("Title")("source")
Debug.Print pstrQLocations("Title")("destination")
End Sub
Related
Coming from Python, I cannot figure out a way to accomplish my end goal since a function like eval() does not exist with Excel VBA.
Below is what I am trying to achieve by using a simple example that I can scale:
Dim userinput as String
userinput = inputbox("A=John, B=Kate, C=Tim", "Enter a letter that corresponds with your name: ")
Dim A as String
Dim B as String
Dim C as String
A = John
B = Kate
C = Tim
Dim Phrase as Variant
phrase = msgbox("Hello, my name is " & userinput)
Result:
User enters a C
msg box pops up as "Hello, my name is Tim"
Regardless of what I try to do, I cannot have a userinput correspond to a variable that is then interpreted while in a string. My macro would be useless without a user's input referencing a much longer and complex phrase that would be too hard for a user to enter on their own.
You're presenting a finite, pre-determined set of options to the user.
Yet you let them enter quite literally anything, not validated, and roll with it.
A much better alternative would be to ditch the InputBox approach and present the user with an actual UserForm, so that the user's input is constrained to a finite, pre-determined set of options - a ComboBox control comes to mind:
The UserForm's code-behind is pretty straightforward - hide the form when a button is clicked, treat "X-out" as a cancellation, expose the user's Selection and whether the form was cancelled via Property Get members, and populate the dropdown with the possible values to pick from:
Option Explicit
Private isCancelled As Boolean
Public Property Get Cancelled() As Boolean
Cancelled = isCancelled
End Property
Public Property Get Selection() As String
Selection = ComboBox1.Value
End Property
Private Sub CancelButton_Click()
isCancelled = True
Hide
End Sub
Private Sub OkButton_Click()
Hide
End Sub
Private Sub UserForm_Activate()
With ComboBox1
.Clear
.AddItem "Lorem"
.AddItem "Ipsum"
'...
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
isCancelled = True
Hide
End If
End Sub
And now you can do this:
Public Sub Test()
With New UserForm1
.Show
If Not .Cancelled Then
MsgBox .Selection
End If
End With
End Sub
This handles the user cancelling out of the prompt, and if your ComboBox control's Style property is set to fmStyleDropDownList, there's absolutely no way the user can supply a value you're not expecting. And you can extend it further by supplying Property Get and Property Let members to configure the Title and Instructions labels as needed, or make the calling code responsible for supplying the list of valid values to populate the ComboBox with.
That's one part of the problem. The next part is "mapping" inputs with another string value. The best data structure for this is a Dictionary, but a keyed Collection can work just as well:
Dim values As Collection
Set values = New Collection
values.Add "string 1", "Lorem"
values.Add "string 2", "Ipsum"
'...
With New UserForm1
.Show
If Not .Cancelled Then
MsgBox values(.Selection)
End If
End With
Of course there are many ways to populate the data you need here, both for the combobox values and the mapped strings in the collection; you can hard-code them like this, or get them from a Range on a worksheet, or from a database, whatever rocks your boat.
The user is typing a letter. You need code to more explicitly translate that into a name. There are a lot of methods - if you have a long list or a user-entered list you may need a solution that is more dynamic. However here is a fix for your code:
Dim userinput as String
userinput = inputbox("A=John, B=Kate, C=Tim", "Enter a letter that corresponds with your name: ")
Dim A as String
Dim B as String
Dim C as String
Dim nameOut as String
select case userinput
case "A"
nameOut = "John"
case "B"
nameOut = "Kate"
case "C"
nameOut = "Tim"
end select
Dim Phrase as Variant
phrase = MsgBox("Hello, my name is " & nameOut)
Note: don't forget to enclose strings in double quotes.
Not to take away from Scott's answer but for a potentially more dynamic approach it seems class modules and callbyname have an answer:
Class module - class1
Private pa As String
Public Property Get a() As String
a = pa
End Property
Public Property Let a(value As String)
pa = value
End Property
Test sub
Sub testing()
Dim cls1 As Class1
Set cls1 = New Class1
cls1.a = "tim"
userinput = "a"
Debug.Print CallByName(cls1, userinput, VbGet)
End Sub
Posted just because it's a different approach. It finds the position of the inputted letter in an array of all three, and then finds the corresponding item in an array of the names.
Sub x()
Dim userinput As String
Dim Phrase As String
Dim v
userinput = InputBox("A=John, B=Kate, C=Tim", "Enter a letter that corresponds with your name: ")
v = Array("John", "Kate", "Tim")
With Application
If IsNumeric(.Match(userinput, Array("A", "B", "C"), 0)) Then
Phrase = .Index(v, .Match(userinput, Array("A", "B", "C"), 0))
MsgBox "Hello, my name is " & Phrase
Else
MsgBox "Wrong letter"
End If
End With
End Sub
I'm trying make to a 3 Dimension Dictionary to store the data in the form of tools(material)(part)(attribute), and I have managed to create the Dictionary like this:
Dim Tools As New Dictionary(Of String, Dictionary(Of String, Dictionary(Of String, Decimal)))
And what I basically want to do is have some subs that manage that for me instead of dealing with that mess, and I want it to be like this like this:
Add_Attribute("Iron", "Pickaxe Head", "Durability", 204)
Get_Attribute("Stone", "Pickaxe Head", "Mining Speed")
Any answers would be greatly be appreciated.
My comment was not worded properly.
Create a class with add/get attributes function that accepts 3 parameters.
Concatenate the parameters and use it as dictionary key.
Option Explicit
Dim oDict As Dictionary
Public Function Add_Attribute(psParam1 As String, psParam2 As String, psParam3 As String, psValue As String)
Dim sKey As String
sKey = BuildKey(psParam1, psParam2, psParam3)
If oDict.Exists(sKey) Then
oDict.Item(sKey) = psValue
Else
oDict.Add sKey, psValue
End If
End Function
Public Function Get_Attribute(psParam1 As String, psParam2 As String, psParam3 As String) As String
Dim sKey As String
sKey = BuildKey(psParam1, psParam2, psParam3)
If oDict.Exists(sKey) Then
Get_Attribute = oDict.Item(sKey)
Else
Get_Attribute = ""
End If
End Function
Private Sub Class_Initialize()
Set oDict = New Dictionary
End Sub
Private Function BuildKey(psParam1 As String, psParam2 As String, psParam3 As String) As String
BuildKey = Join(Array(psParam1, psParam2, psParam3), "#")
End Function
Private Sub Class_Terminate()
Set oDict = Nothing
End Sub
Jules' answer of a custom class and concatenation of the three strings as a key will work very nicely for you and is a neat solution to your problem.
I'm posting another answer here for anyone who wants more of a dot notation style of solution. So one of the lines in your example could look something like:
mTools("Pickaxe Head").Attr("Durability").Material("Iron") = 204
I'm guessing you're deriving the values from a comboxbox or something similar, so working with strings might serve you fine. However, if you wished, you could go one stage further and create objects for the Attributes and Material parameters to achieve true dot notation (I didn't do the Parts parameter but you could do that one too):
mTools("Pickaxe Head").Durability.OnIron = 204
From a development point of view, the time consuming part would be to create all the parameter objects and keys, but if you are intending to manipulate the data anything more than trivially, it could make your life easier further down the track.
For your own project, are you certain that the data is genuinely 3 dimensional? Perhaps it's just the variable names that you've picked, but it seems as though you have one main object, ie the part (Pickaxe Head) which has some attributes (Durability and Mining Speed) which themselves have values based on the material they're operating on (Stone and Iron). Structurally, could it look like this?:
In terms of the code for this solution, create three classes. I've called them clsKeys, clsMaterials and clsPart.
For your clsKeys, the code is simply your field names:
Public Durability As String
Public MiningSpeed As String
Public Iron As String
Public Stone As String
For clsPart, the code contains the object names and a means of accessing them by string:
Public Name As String
Public Durability As New clsMaterials
Public MiningSpeed As New clsMaterials
Private mProperties As New Collection
Public Property Get Attr(field As String) As clsMaterials
Set Attr = mProperties(field)
End Property
Private Sub Class_Initialize()
With Keys
mProperties.Add Durability, .Durability
mProperties.Add MiningSpeed, .MiningSpeed
End With
End Sub
clsMaterials is similar:
Public OnStone As Integer
Public OnIron As Integer
Private mProperties As New Collection
Public Property Let Material(field As String, value As Variant)
mProperties.Remove field
mProperties.Add value, field
End Property
Public Property Get Material(field As String) As Variant
Material = mProperties(field)
End Property
Private Sub Class_Initialize()
With Keys
mProperties.Add OnStone, .Stone
mProperties.Add OnIron, .Iron
End With
End Sub
These classes can take as many objects as you like. You'll note I've instantiated the objects in the declaration which isn't best form but I've done it in the interest of space.
Finally, in a Module you need 3 routines: one to create the field keys, one to populate the data and one to retrieve it.
For the keys:
Option Explicit
Public Keys As clsKeys
Private mTools As Collection
Sub CreateKeys()
Set Keys = New clsKeys
With Keys
.Durability = "Durability"
.MiningSpeed = "Mining Speed"
.Iron = "Iron"
.Stone = "Stone"
End With
End Sub
For data population:
Sub PopulateData()
Dim oPart As clsPart
Set mTools = New Collection
Set oPart = New clsPart
With oPart
.Name = "Pickaxe Head"
'You could use dot notation
.Durability.OnIron = 204
.Durability.OnStone = 100
'Or plain strings
.Attr("Mining Speed").Material("Stone") = 50
.Attr("Mining Speed").Material("Iron") = 200
mTools.Add oPart, .Name
End With
End Sub
and for data retrieval:
Sub RetrieveValue()
Dim oPart As clsPart
Dim v As Variant
Set oPart = mTools("Pickaxe Head")
With oPart
'Using dot notation
v = oPart.Durability.OnIron
Debug.Print v
'Using plain strings
v = oPart.Attr("Durability").Material("Stone")
Debug.Print v
End With
'Or even without assigning the oPart variable
v = mTools("Pickaxe Head").Attr("Mining Speed").Material("Iron")
Debug.Print v
End Sub
I have a macro (code attached) which writes the data from two sheets into two variant arrays. It then uses a nested loop to look for all possible matches in the 2nd sheet on a piece of data in the 1st sheet.
When the first match is found one of the variant arrays appears to get wiped and I get a 'Subscript out of range'. this can happen when the data is being compared or when I subsequently try to pass data from that array to another procedure as a result of a match being found.
When I look in the Locals window, this array can change from showing the stored values to having the error message "Application-defined or object-defined error" in each index, or no indexes at all, or indexes with high negative numbers.
Regardless, if I try to investigate further while the code is in debug mode, Excel crashes ("Excel has encountered a problem and needs to close").
I have followed the advice at this link:
http://exceleratorbi.com.au/excel-keeps-crashing-check-your-vba-code/
...but to no avail.
I've stepped through the code and can trace it to the first time the data values being tested match. It happens for the same indexes (same i and j values) every time I run.
I'm using Excel 2013 on our office network.
Can anyone tell me what might be causing this or any tests I could perform to help narrow down the cause?
Could it be due to memory use? The arrays come out at about 15000 x 11 and 4000 x 6 and it's the smaller one that is being corrupted/failing.
Sub classTest()
Dim i As Long, j As Long
Dim CK_Array() As Variant, RL_Array() As Variant
Dim wb As Workbook
Dim CK_Data As Worksheet, RL_Data As Worksheet
Set wb = ThisWorkbook
Set CK_Data = wb.Sheets(1)
Set RL_Data = wb.Sheets(2)
Call getRange_BuildArray(CK_Array, CK_Data)
Call getRange_BuildArray(RL_Array, RL_Data) ' this sets the array that gets corrupted.
For i = 2 To UBound(CK_Array)
If Not IsEmpty(CK_Array(i, 6)) Then
For j = 2 To UBound(RL_Array)
If CK_Array(i, 6) = RL_Array(j, 4) Then ' array gets corrupted here or line below
Call matchFound(dResults, CStr(CK_Array(i, 1) & " | " & CK_Array(i, 5)), CStr(RL_Array(j, 2) & " " & RL_Array(j, 3)), CStr(RL_Array(j, 1)), CStr(RL_Array(1, 3))) ' or array gets corrupted here
End If
Next j
End If
Next i
End Sub
Private Sub getRange_BuildArray(arr As Variant, ws As Worksheet)
Dim endR As Long, endC As Long
Dim rng As Range
endR = ws.UsedRange.Rows.Count
endC = ws.UsedRange.Columns.Count
Set rng = Range(ws.Cells(1, 1), ws.Cells(endR, endC))
arr = rng
End Sub
EDIT:
As requested here is the code to the matchfound Sub. It's a dictionary, which holds class objects in a collection. Therefore I have also posted the class code below. I'm not yet making use of all of the class properties and methods as this issue has halted my testing.
Sub matchFound(dictionary As Object, nameCK As String, nameRL As String, RLID As String, dataitem As String)
Dim cPeople As Collection
Dim matchResult As CmatchPerson
If dictionary.exists(nameCK) Then
Set matchResult = New CmatchPerson
matchResult.Name = nameRL
matchResult.RLID = RLID
matchResult.matchedOn = dataitem
dictionary.Item(nameCK).Add matchResult
Else
Set cPeople = New Collection
Set matchResult = New CmatchPerson
matchResult.Name = nameRL
matchResult.RLID = RLID
matchResult.matchedOn = dataitem
cPeople.Add matchResult
dictionary.Add nameCK, cPeople
End If
End Sub
Class
Option Explicit
Private pName As String
Private pRLID As String
Private pMatchedOn As String
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Name As String)
pName = Name
End Property
Public Property Get RLID() As String
RLID = pRLID
End Property
Public Property Let RLID(ID As String)
pRLID = ID
End Property
Public Property Get matchedOn() As String
matchedOn = pMatchedOn
End Property
Public Property Let matchedOn(textString As String)
pMatchedOn = textString
End Property
Public Sub MatchedOnString(datafield As String)
Dim text As String
text = Me.matchedOn & "|" & datafield
Me.Name = text
End Sub
I've reduced your problem to a Minimum, Verifiable and Complete Example.
The problem occurs when you assign the implicit default value of a range to a Variant variable that was passed as a Variant array.
Sub VariantArrayWTF()
Dim aBar() As Variant
Dim aFoo() As Variant
GetArray aBar
GetArray aFoo
Debug.Print aBar(1, 1)
'aFoo() has now lost it's `+` sign in Locals window, but the bounds are still visible
Debug.Print aBar(1, 1)
'aFoo() has now lost its bounds in Locals Window
'aFoo(1,1) will produce subscript out of range
'Exploring the Locals Window, incpsecting variables, will crash Excel
Debug.Print aFoo(1, 1)
End Sub
Sub GetArray(ByRef theArray As Variant)
'Note the use of theArray instead of theArray()
'Implicitly calling the default member is problematic
theArray = Sheet1.UsedRange
End Sub
There are a number of workarounds - I'd recommend using both:
Use Explicit calls to `Range.Value`
You can even make explicit call to the default member Range.[_Default]. The exact method isn't important, but it must be explicit.
Sub GetArray(ByRef theArray As Variant)
theArray = Sheet1.UsedRange.Value
End Sub
Avoid the use of `Call`, and pass common Variant definitions
Call is a deprecated statement, and can be omitted.
Declare the arrays and the helper functions' array argument consistently. That is, use () in all instances, or none.
Note the difference between declaring Dim aFoo() As Variant which is an array of Variants, and declaring Dim aFoo As Variant which is a Variant that can contain an array.
With Parentheses
Sub VariantArrayWTF()
Dim aBar() As Variant
Dim aFoo() As Variant
GetArray aBar
GetArray aFoo
Debug.Print aBar(1, 1)
Debug.Print aBar(1, 1)
Debug.Print aFoo(1, 1)
End Sub
Sub GetArray(ByRef theArray() As Variant)
theArray = Sheet1.UsedRange
End Sub
Without Parentheses
Sub VariantArrayWTF()
Dim aBar As Variant
Dim aFoo As Variant
GetArray aBar
GetArray aFoo
Debug.Print aBar(1, 1)
Debug.Print aBar(1, 1)
Debug.Print aFoo(1, 1)
End Sub
Sub GetArray(ByRef theArray As Variant)
theArray = Sheet1.UsedRange
End Sub
I have found the lines of code which were causing the problem. However, I cannot explain why it would necessarily cause a crash so I would appreciate other input on why this is happening.
When passing the RL and CK arrays to the getRange_Build Array sub I left out the brackets that would have denoted these variables as arrays.
The code was this...
Call getRange_BuildArray(CK_Array, CK_Data)
Call getRange_BuildArray(RL_Array, RL_Data)
...but should have been this
Call getRange_BuildArray(CK_Array(), CK_Data)
Call getRange_BuildArray(RL_Array(), RL_Data)
I'm thinking the reason that this didn't get flagged as a compile error is because the parameter in question in the getRange_BuildArray procedure itself also lacked the necessary brackets to denote an array.
It was this...
Private Sub getRange_BuildArray(arr As Variant, ws As Worksheet)
...it should have been this
Private Sub getRange_BuildArray(arr() As Variant, ws As Worksheet)
With those changes in place the macro is completing successfully for the full dataset and is not causing excel to crash.
As mentioned it would be great if someone could offer a more detailed breakdown of how this caused excel to crash.
I have a program where I create several different collections in VBA. After the program completes, I need to delete the records in each collection. I have been able to delete the collections statically with the following code:
Sub Empty_Collections()
Dim Count As Integer
Dim i As Long
Count = Managers.Count
For i = 1 To Count
Managers.Remove (Managers.Count)
Next i
Count = FS.Count
For i = 1 To Count
FS.Remove (FS.Count)
Next i
Count = Staff.Count
For i = 1 To Count
Staff.Remove (Staff.Count)
Next i
Count = Clusters.Count
For i = 1 To Count
Clusters.Remove (Clusters.Count)
Next i
End Sub
However, as I may add additional Collections in the future, is it possible to have code similar to this:
Dim Item As Collection
Dim Count As Integer
Dim i As Long
For Each Item In Worksheets
Count = Item.Count
For i = 1 To Count
Item.Remove (Item.Count)
Next i
Next
While I hesitate to create globals like this, here is a possible solution:
In the ThisWorkbook Excel Object, add the following:
Private pCollections As Collection
Public Property Get Collections() As Collection
If pCollections Is Nothing Then: Set pCollections = New Collection
Set Collections = pCollections
End Property
Public Property Set Collections(Value As Collection)
Set pCollections = Value
End Property
Public Sub AddCollection(Name As String)
Dim Coll As New Collection
Me.Collections.Add Coll, Name
End Sub
Public Sub EmptyCollections()
Dim Coll As Collection
For Each Coll In Me.Collections
EmptyCollection Coll
Next Coll
End Sub
Private Sub EmptyCollection(ByRef Coll As Collection)
Do While Coll.Count > 0
' Remove items from the end of the collection
Coll.Remove Coll.Count
Loop
End Sub
Then add and work with collections as follows:
' Add collections
' (without helper)
Dim Managers As New Collection
ThisWorkbook.Collections.Add Managers, "Managers"
' (with helper)
ThisWorkbook.AddCollection "FS"
ThisWorkbook.AddCollection "Staff"
ThisWorkbook.AddCollection "Clusters"
' Add items to collection
' (access collection via named key for ease-of-use)
ThisWorkbook.Collections("Managers").Add "Alice"
ThisWorkbook.Collections("Managers").Add "Bob"
' (or original reference if desired
Managers.Add "Carl"
Debug.Print Managers.Count ' => 3
Debug.Print ThisWorkbook.Collections("Managers").Count ' => 3
' Add collection later
ThisWorkbook.AddCollection "FutureCollection"
' Empty all collections
ThisWorkbook.EmptyCollections
This may be a little more complex than what you are looking for, but it has the advantage of adding collections to a central location so that they can all be emptied later.
How do I get a public array whose values are set within a subroutine and do not get cleared at the end of the sub in which they were set?
I tried to get:
Public GlobalArray() as Variant
Sub One()
ReDim GlobalArray(0 to 2)
GlobalArray=Array("0","1","2")
End Sub
Sub Two()
Check = GlobalArray(2)
End Sub
such that Check = 2, but I get thrown an error in sub Two complaining about a lack of values in GlobalArray (in fact, even sub One complains that there is no GlobalArray to put things in).
Basically, I have a procedure (One) pulling data from disparate sources, doing some stuff with it, letting the user do some things in Excel, and then running a new subroutine (Two) that uses both the user's input and some of the arrays from sub One.
The Public GlobalArray() variable must be declared in a module. It will not work if it is declared at the top of either a Worksheet or the ThisWorkbook module. Try:
'// Must be declared in a module
Public GlobalArray() As Integer
'// These routines can be in worksheet/thisworkbook modules along side events etc Or in a module
Sub One()
ReDim GlobalArray(0 To 2)
GlobalArray(0) = 0
GlobalArray(1) = 1
GlobalArray(2) = 2
End Sub
Sub Two()
check = GlobalArray(2)
MsgBox (check)
End Sub
Instead of a public variable you could pass it to the second function:
Sub One()
Dim GlobalArray(0 To 2) As Integer
GlobalArray(0) = 0
GlobalArray(1) = 1
GlobalArray(2) = 2
Two GlobalArrayToMe:=GlobalArray
End Sub
Sub Two(ByRef GlobalArrayToMe() As Integer)
check = GlobalArrayToMe(2)
MsgBox (check)
End Sub
This is not VBA and won't compile: GlobalArray=("0","1","2")
You could instead use: GlobalArray = Array("0", "1", "2")
but that requires declaring Public GlobalArray() As Variant
Otherwise assign the array elements one by one as in #Readfidy's answer.