Convert Text String Into VBA Statement/Object - vba

I need to create a bunch of dictionaries in VBA; the best solution is to concatenate prefix "dict" with a string variable (enumeration would cause more complexities). Is there a way to convert a string into a VBA statement?
For example, I have a dictionary dictABC created. How to refer to it by using two segment of strings, "dict" and "ABC" concatenated?
(The only way I could think of is to create a "meta-dictionary", with pairs of string "dictABC" and dictionary dictABC.)

If you build an array of dictionary objects and use another single dictionary to act as the index of all of the dictionaries you've created, you should get something akin to what you have described. Consider the following data that has three unique values in Col A.
Col A Col B Col C Col D
Y 196 RNT 4-Jan-2015
Y 127 IYI 12-Feb-2015
X 173 ZVM 24-Jan-2015
Z 124 LRP 16-Jan-2015
Z 176 XTN 27-Jan-2015
Y 137 SUG 30-Jan-2015
X 139 IBG 7-Feb-2015
X 165 DON 11-Feb-2015
Z 153 EUU 16-Feb-2015
After adding Microsoft Scripting Runtime to the VBE's Tools ► References we can run down column A, adding a key entry and index number to the index of dictionaries then redimming the array of dictionaries for room and populating that new dictionary object. If a value in column A already exists, the dNDX is used to figure out which dictionary object in the array should be referenced and adds a new key/item.
Sub mcr_Dict_Over_Dicts()
Dim rw As Long, d As Long, sCOLa As String, ky As Variant
Dim dNDX As New Scripting.Dictionary, dDICTs() As New Scripting.Dictionary
dNDX.CompareMode = TextCompare 'or BinaryCompare
With ActiveSheet
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
sCOLa = .Cells(rw, 1).Value
If CBool(Len(sCOLa)) Then
If Not dNDX.Exists(sCOLa) Then
'create a new entry in dNDX and a new dictionary in the array
d = dNDX.Count + 1
dNDX.Add Key:=sCOLa, Item:=d
ReDim Preserve dDICTs(1 To d)
dDICTs(d).Add Key:=.Cells(rw, 2).Text, _
Item:=Join(Array(.Cells(rw, 1).Text, .Cells(rw, 2).Text, .Cells(rw, 3).Text, .Cells(rw, 4).Text), ChrW(8203))
Else
'add an entry to an existing dictionary
dDICTs(dNDX.Item(sCOLa)).Add Key:=.Cells(rw, 2).Text, _
Item:=Join(Array(.Cells(rw, 1).Text, .Cells(rw, 2).Text, .Cells(rw, 3).Text, .Cells(rw, 4).Text), ChrW(8203))
End If
End If
Next rw
'return the values to the worksheet reordered in an alternate location
.Cells(1, 6).Resize(1, 4) = .Cells(1, 1).Resize(1, 4).Value
For d = LBound(dDICTs) To UBound(dDICTs)
For Each ky In dDICTs(d)
.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Resize(1, 4) _
= Split(dDICTs(d).Item(ky), ChrW(8203))
Next ky
Next d
End With
For d = LBound(dDICTs) To UBound(dDICTs)
dDICTs(d).RemoveAll
Next d
'alternately redim dDICTs
ReDim dDICTs(1)
dNDX.RemoveAll
Set dNDX = Nothing
End Sub
This does demand that there will be some value or combination of values (hash) that can be used as a unique key within each of the dictionaries in the array.
      
Note that the results in columns G and I are text based. This is a result of them being split out of a concatenated string.

I'm confused why you've thought of and for some reason rejected the simple, obvious solution.
But if you really want to go the code generation route, this is how you would do it.
Function dictAbcd() As Object
Static result As Object
If result Is Nothing Then
Set result = CreateObject("Scripting.Dictionary")
End If
Set dictAbcd = result
End Function
Public Sub Test()
Dim x As Object
Dim dict_index As String
dictAbcd("key") = "value"
dict_index = "Abcd"
Set x = Application.Run("dict" & dict_index)
Debug.Print x("key") ' Prints "value"
End Sub
N.b. doing it this way is completely ridiculous.

You could put the dictionaries into a collection, which allows you to have a string index.

Related

Getting unique values using dictionary - would like to understand more

I have this code I made from studying multiple posts.
https://www.youtube.com/watch?v=j2RfI75Yfg8
https://www.mrexcel.com/board/threads/storing-unique-values-from-advanced-filter-to-an-array.1048617/
Option Explicit
Sub GetTheUniqueValues()
Dim dict As New Scripting.Dictionary
Dim rng_col_a As Range
Dim col_a_last_row As Long
Dim source_array As Variant
Dim i As Long
Dim j As Long
Dim new_array As Variant
dict.CompareMode = TextCompare
col_a_last_row = ActiveSheet.Range("A1048576").End(xlUp).row
Set rng_col_a = Range(ActiveSheet.Range("A2"), ActiveSheet.Range("A" & col_a_last_row))
source_array = rng_col_a
For i = LBound(source_array) To UBound(source_array)
If source_array(i, 1) <> "" Then dict(source_array(i, 1)) = Empty
Next i
new_array = dict.Keys
For j = LBound(new_array) To UBound(new_array)
ActiveSheet.Range("H" & j + 2).Value = new_array(j)
Next j
End Sub
I would like to understand more about
If source_array(i, 1) <> "" Then dict(source_array(i, 1)) = Empty
I am new to VBA and programming in general so may I now what the "dict(source_array(i, 1)) = Empty" does and why this particular line of code is effective of only putting unique values in the dictionary.
What does it do if the condition is true?
What does it do if the condition is false?
Thank you.
Using dict("a") = Empty tells the dict dictionary that its element with key a has no value (is Empty).
If the dict dictionary doesn't have a key "a", then the code dict("a") = Empty will create it.
That means when cycling through all the values in the source_array, it won't (can't) create duplicates. If key "a" already exists it'll just assign Empty to it again, if it doesn't exist, it'll create it.
This is better than trying to add keys e.g. using
dict.Add "a", Empty
Will only work if key "a" doesn't already exist, but e.g.
dict("a") = Empty
Will either assign Empty to key "a" or create it. It can't error like the first method.
The If source_array(i, 1) <> "" is simply checking that there is a value to create in the first place.
If it's true then it'll try to create the key, if it's false it'll just move to the next i value.
If source_array(i, 1) <> "" Then dict(source_array(i, 1)) = Empty only create a new key and do not allocate any value. If instead of Empty will be 1, the final result will be the same, due to the fact that only the dictionary (unique) keys count...
dict.Keys is an array (independent of the key item values) and only it is used by this code. A shorter version of dropping the dictionary keys would be (without iteration between the array elements):
ActiveSheet.Range("H2").Resize(UBound(new_array) + 1, 1).Value = WorksheetFunction.Transpose(new_array)
A shorter (but interesting, I think) version, for the whole code, would be the next one (it does not need a reference to 'Microsoft Scripting Runtime'):
Sub GetTheUniqueValues()
Dim source_array As Variant, sh As Worksheet, j As Long, col_a_last_row As Long
Set sh = ActiveSheet
col_a_last_row = sh.Range("A" & Rows.count).End(xlUp).row
source_array = sh.Range(sh.Range("A2"), sh.Range("A" & col_a_last_row)).Value
With CreateObject("scripting.dictionary")
For j = 1 To UBound(source_array)
.Item(source_array(j, 1)) = Application.Index(source_array, j, 0)
Next
sh.Range("H2").Resize(.count, UBound(source_array, 2)) = Application.Index(.Items, 0, 0)
End With
End Sub
It would be a bigger challenge to understand it. But still not something very complicated...

Excel VBA - Formula Counting Unique Value error

I am trying to calculate the count of Unique values based on a condition.
For example,
For a value in column B, I am trying to count the Unique values in Column C through VBA.
I know how to do it using Excel formula -
=SUMPRODUCT((B2:B12<>"")*(A2:A12=32)/COUNTIF(B2:B12,B2:B12))
that value for 32 is dynamic - Programmatically I am calling them inside my vba code as Name
This is my code :
Application.WorksheetFunction.SumProduct((rng <> "") * (rng2 = Name) / CountIfs(rng, rng))
This is the sample data with the requirement
Alternatively, I Concatenated both the columns for keeping it simple and hoping to identify the Unique values which starts with name* method.
I don't know where I am going wrong. Kindly share your thoughts.
You may try something like this...
Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
If x(i, 1) = Lookup Then
dict.Item(x(i, 1) & x(i, 2)) = ""
End If
Next i
GetUniqueCount = dict.Count
End Function
Then you can use it like below...
=GetUniqueCount($A$2:$B$10,C2)
Where A2:B10 is the data range and C2 is the name criteria.
I'd put the values into an array, create a temporary 2nd array and only add values to this array if they are not already present, and then replace the original array. Then it's just a simple matter to sum the unique values:
Sub Unique
dim arr(10) as variant, x as variant
dim arr2() as variant
for x = 1 to 10 ' or whatever
arr(x) = cells(x, 1) ' or whatever
next x
arr2 = UniqueValuesArray(arr)
' now write some code to count the unique values, you get the idea
End Sub
Function UniqueValuesArray(arr As Variant) As Variant()
Dim currentRow, arrpos As Long
Dim uniqueArray() As Variant
Dim x As Long
arrpos = 0
ReDim uniqueArray(arrpos)
For x = 0 To UBound(arr)
If UBound(Filter(uniqueArray, arr(x))) = -1 Then
ReDim Preserve uniqueArray(arrpos)
uniqueArray(arrpos) = arr(x)
arrpos = arrpos + 1
End If
Next x
UniqueValuesArray = uniqueArray
End Function

How do I use a string as a variable in vba?

This is what my cells look like:
This is my code, I'll explain it below.
Sub Macro1()
Dim product as String
Dim group as Long
Dim recordno as Long
dim pol_number as Long
dim plan_name as Long
product = "corp"
group = 1
recordno = 1
pol_number = 1
plan_name = "TTT"
Range("A2").Select
For i = 1 to 5
ActiveCell.Value = Selection.End(xlUp).Value
ActiveCell.Offset(0,1).Select
Next i
End Sub
I want to fill in all of the cells with the variable values. I understand that variables are not case sensitive, and I understand that the code I have will just fill the cell with the text in the upmost cell of the column, but I don't know if there is a function that would take the text of the top cell and convert it to a variable. Is that possible?
Try this to go from variables to cells
Dim values as Variant
'Array 0 to 4
values = Array(product,group,recordno,pol_number,plan_name)
Range("A2").Resize(1,5).Value2 = values
The reverse is
Dim values as Variant
'Array 1 to 5
values = Range("A2").Resize(1,5).Value2
product = values(1,1)
group = values(1,2)
recordno = values(1,3)
pol_number = values(1,4)
plan_name = values(1,5)
If you do something like
someCell.Value = someOtherCell.Value
and someOtherCell.Value is "product" then someCell won't be filled with what you have saved in the variable product but with "product" (I included the quotation marks to emphasize that's it's a string). That's a good thing because otherwise it would mess your code up if you accidentally put in the name of some random variable in your code.
If your requirements are like this:
You have values for PRODUCT etc that you write to write in the row below PRODUCT etc.
The headers are not always in the same order.
You might want to add new variables later on without too much fuss.
Them some kind of keyed list might be what your looking for. That means that rather than referencing the variable by a numerical index, you can reference them using names.
If the order is fixed, you might be better of just using an array where item 1 is the product name, item 2 is the group number etc, like ja72 and Sgdva suggested.
However, if you still want to reference the variables by name, you could use a collection:
Dim coll As New Collection
With coll
.Add "corp", "product"
.Add 1, "group"
.Add 1, "recordno"
'...
End With
Then instead of selecting cells and referencing ActiveCell you should reference the cells directly (using selections and ActiveCell can be avoided most of the times and slows down the macro and can even cause unnecessary errors)
For i = 1 To 5
Cells(2, i).value = coll(Cells(1, i).value)
Next i
An alternative to a collection is a dictionary which offers an easy way to check if a key exists (with a collection you have to catch the error)
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With dict
.Add "product", "corp"
.Add "group", 1
.Add "recordno", 1
'...
End With
Now you can check if the entry exists first so it won't throw an error:
For i = 1 To 5
If dict.Exists(LCase(Cells(1, i).value)) Then 'note that the dictionary keys are case sensitive
Cells(2, i).value = dict(LCase(Cells(1, i).value))
Else
MsgBox "Entry for " & LCase(Cells(1, i).value) & " not found!"
End If
Next i
Note that when you use dict("somekey") and the entry "somekey" doesn't exist, it won't throw an error but add an empty entry.
Why not an array and then loop through the elements as needed?
Dim ArrayTitles() As Variant 'since strings and numbers are mixed
ReDim Preserve ArrayTitles(5)
ArrayTitles(1) = "corp"
ArrayTitles(2) = 1
ArrayTitles(3) = 1
ArrayTitles(4) = 1
ArrayTitles(5) = "TTT"
Range("A2").Select
For i = 1 To 5
MsgBox (ArrayTitles(i))
I'm thinking what you are trying to accomplish can be solved in this way
for j = 1 to 6 'Or whatever your last column happens to be
if UCase(cells(1, j)) = "PRODUCT" then
if ActiveCell.Column = j then
ActiveCell.Value = "corp"
end if
end if
next j
Something like that?

Custom sort routine for unique string A being place after another string B, C, D, etc if string A is found within them

Situation
I have a UDF that works with a range that it is passed that is of variable height and 2 columns wide. The first row will contain text in column 1 and an empty column2. The remainder of column 1 will contain unsorted text with an associated value in the same row in column 2. I need to sort the data such that if some text in column 1 also appears in some other text in column.
Problem
My VBA skills are all self taught and mimimal at best. I remember a few decades ago in university we did bubble sorts and played with pointers, but I no longer remember how we achieved any of that. I do well reading code but creating is another story.
Objective
I need to generate a sort procedure that will produce unique text towards the bottom of the list. I'll try wording this another way. If text in column1 can be found within other text in column, that the original text need to be placed below the other text it can be found in along with its associated data in column 2. The text is case sensitive. Its not an ascending or descending sort.
I am not sure if its a restriction of the UDF or not, but the list does not need to be written back to excel, it just needs to be available for use in my UDF.
What I have
Public Function myFunk(rng As Range) As Variant
Dim x As Integer
Dim Datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
Datarange = rng.Value
'insert something around here to get the list "rng or Datarange" sorted
'maybe up or down a line of code depending on how its being done.
Equation = Datarange(1, 1)
For x = 2 To UBound(Datarange, 1)
VariablesLength = Len(Datarange(x, 1)) - 1
Variable = Left$(Datarange(x, 1), VariablesLength)
Equation = Replace$(Equation, Variable, Datarange(x, 2))
Next x
myFunk = rng.Worksheet.Evaluate(Equation)
End Function
Example Data
Any help with this would be much appreciated. In that last example I should point out that the "=" is not part of the sort. I have a routine that strips that off the end of the string.
So in order to achieve what I was looking for I added a SWAP procedure and changed my code to look like this.
Public Function MyFunk(rng As Range) As Variant
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
'convert the selected range into an array
datarange = rng.Value
'verify selected range is of right shape/size
If UBound(datarange, 1) < 3 Or UBound(datarange, 2) <> 2 Then
MyFunk = CVErr(xlErrNA)
Exit Function
End If
'strip the equal sign off the end if its there
For x = 2 To UBound(datarange, 1)
If Right$(datarange(x, 1), 1) = "=" Then
datarange(x, 1) = Left$(datarange(x, 1), Len(datarange(x, 1)) - 1)
End If
Next x
'sort the array so that a variable does not get substituted into another variable
'do a top down swap and repeat? Could have sorted by length apparently.
For x = 2 To UBound(datarange, 1) - 1
For y = x + 1 To UBound(datarange, 1)
If InStr(1, datarange(y, 1), datarange(x, 1)) <> 0 Then
For z = LBound(datarange, 2) To UBound(datarange, 2)
Call swap(datarange(y, z), datarange(x, z))
Next z
y = UBound(datarange, 1)
x = x - 1
End If
Next y
Next x
'Set the Equation
Equation = datarange(1, 1)
'Replace the variables in the equation with values
For x = 2 To UBound(datarange, 1)
Equation = Replace$(Equation, datarange(x, 1), datarange(x, 2))
Next x
'rest of function here
End Function
Public Sub swap(A As Variant, B As Variant)
Dim Temp As Variant
Temp = A
A = B
B = Temp
End Sub
I sorted by checking to see if text would substitute into other text in the list. Byron Wall made a good point that I could have sorted based on text length. Since I had completed this before I saw the suggestion it did not get implemented though I think it may have been a simpler approach.

I need to format data in VBA

I need to format a large set of data across multiple columns.
I have data in sets of 2 columns that need to be formatted into one set of 2 columns, in addition to headers that need to be in cells to the left of the data.
So I need to covert data that is in two columns to:
header1 header2 data1 data2
So the header needs to be copied and pasted all the way down the columns and the multiple columns and headers need to be appended.
This needs to loop across a whole spreadsheet.
Below is my attempt
colA = 5
colB = 3
colC = 2
rowA = 3
rowB = 3
cellA = "C1"
Worksheets("sheet3").Activate
lastA = Cells(Rows.Count, colB).End(xlUp).Row
For x = rowA To lastA
Worksheets("sheet3").Activate
Data = Cells(x, colA)
Worksheets("sheet3").Activate
Cells(rowB, colB) = Data
rowB = rowB + 1
Next x
Do Until colC = 0
Selection.Cut
Cells(1, colB).Select
ActiveSheet.Paste
Range("D1").Select
Selection.AutoFill Destination:=Cells(3, colC)
colC = colB - 1
Different approach.
Read the source data into an array.
Set up a Class consisting of the data for each resultant row
Iterate through the source array, two columns at a time, to construct each row.
Store the RowData into a collection.
When done, transfer the collection into a "results" array.
Write the results array to a Range (I chose to do do this on a different worksheet). Edit the source and destination ranges as required.
First Insert a Class Module; Rename it RowData, and paste the code below:
Option Explicit
Private pHeaderOdd As String
Private pHeaderEven As String
Private pDataOdd As String
Private pDataEven As String
Public Property Get HeaderOdd() As String
HeaderOdd = pHeaderOdd
End Property
Public Property Let HeaderOdd(Value As String)
pHeaderOdd = Value
End Property
Public Property Get HeaderEven() As String
HeaderEven = pHeaderEven
End Property
Public Property Let HeaderEven(Value As String)
pHeaderEven = Value
End Property
Public Property Get DataOdd() As String
DataOdd = pDataOdd
End Property
Public Property Let DataOdd(Value As String)
pDataOdd = Value
End Property
Public Property Get DataEven() As String
DataEven = pDataEven
End Property
Public Property Let DataEven(Value As String)
pDataEven = Value
End Property
Then, in a regular module, paste the following code:
Sub ReFormat()
Dim V As Variant, vRes() As Variant
Dim cRD As RowData
Dim colRD As Collection
Dim I As Long, J As Long
'Get entire source data into array
'May need a different selection method
' depending on your "real" data arrangement
V = Worksheets("Sheet4").Range("a1").CurrentRegion
'initialize collection
Set colRD = New Collection
'get data in pairs and add to collection
For I = 1 To UBound(V, 2) Step 2 'columns
For J = 2 To UBound(V, 1) 'rows
Set cRD = New RowData
cRD.HeaderOdd = V(1, I)
cRD.HeaderEven = V(1, I + 1)
cRD.DataOdd = V(J, I)
cRD.DataEven = V(J, I + 1)
colRD.Add cRD
Next J
Next I
'Put collection into "results" array for writing to the results range
ReDim vRes(1 To colRD.Count, 1 To 4)
For I = 1 To colRD.Count
vRes(I, 1) = colRD(I).HeaderOdd
vRes(I, 2) = colRD(I).HeaderEven
vRes(I, 3) = colRD(I).DataOdd
vRes(I, 4) = colRD(I).DataEven
Next I
Worksheets("Sheet2").Cells.Clear
Worksheets("Sheet2").Range("A1").Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
Ensure your worksheet and range references are correct, and run the macro.