VBA Handling multiple custom datatype possibilities - vba

I have done some research and haven't found any similar question.
I have a VBA macro that imports a .CSV file containing telegrams sent by a device.
In the end of this macro, I want to create a graph with the time elapsed on the x-axis and the value corresponding to the telegram.
The issue is that this value can be of different types: hexadecimal, boolean, integer... And that they don't respect the standard Excel number format, which means that they can't be used to create a graph.
Here are some examples (with " around the value to show its start and end) :
hexadecimal : "A7 C8"
Boolean : "$00" or ""$01"
Percentage : "$30"
And here is an example of data, with custom time format and boolean value
Here is my related code so far, where I try to convert into a custom type then convert back to numeric to get a common number datatype :
If wsRes.Range("R1").Value Like "$##" Then
wsRes.Range("R1:R" & plotLine).NumberFormat = "$##"
wsRes.Range("R1:R" & plotLine).NumberFormat = General
End If
If wsRes.Range("R1").Value Like "??[ ]??" Then
Dim valArray(1) As String
For i = 1 To plotLine Step 1
valArray = Split(wsRes.Range("R" & i), " ")
wsRes.Range("R" & i).Value = ToInt32(valArray(0) + valArray(1), 16)
wsRes.Range("" & i).NumberFormat = General
Next i
End If
I haven't been able to test it with hexa yet, but the conversion trick doesn't work with percentage/boolean
EDIT :
First, thank you for your answers.
Here is my final code for anyone's interested, adapted from Vityata's.
This method will allow to easily add other datatypes if needed.
Sub TestMe()
Dim RangeData as String
Set wsRes = ActiveWorkbook.Sheets("Results")
For i = 1 To plotLine Step 1 'plotLine is the last line on which I have data
DetectType wsRes.Range("R" & i).Value, i
Next i
RangeData = "Q1:R" & plotLine
CreateGraph RangeData 'Call My sub creating the graph
End Sub
Public Sub DetectType(str As String, i As Integer)
Select Case True
Case wsRes.Range("R" & i).Value Like "??[ ]??"
wsRes.Range("R" & i).Value = HexValue(str)
Case wsRes.Range("R" & i).Value Like "?##"
wsRes.Range("R" & i).Value = DecValue(str)
Case Else
MsgBox "Unsupported datatype detected : " & str
End
End Select
End Sub
Public Function HexValue(str As String) As Long
Dim valArray(1) As String 'Needed as I have a space in the middle that prevents direct conversion
valArray(0) = Split(str, " ")(0)
valArray(1) = Split(str, " ")(1)
HexValue = CLng("&H" & valArray(0) + valArray(1))
End Function
Public Function DecValue(str As String) As Long
DecValue = Right(str, 2)
End Function

You need three boolean functions, following your business logic and some of the Clean Code principles (although the author of the book does not recognize VBA people as programmers):
IsHex()
IsBoolean()
IsPercentage()
Public Sub TestMe()
Dim myInput As Variant
myInput = Array("A7C8", "$01", "$30")
Dim i As Long
For i = LBound(myInput) To UBound(myInput)
Debug.Print IsHex(myInput(i))
Debug.Print IsBoolean(myInput(i))
Debug.Print IsPercentage(myInput(i))
Debug.Print "-------------"
Next i
'or use this with the DetectType() function below:
'For i = LBound(myInput) To UBound(myInput)
' Debug.Print DetectType(myInput(i))
'Next i
End Sub
Public Function IsHex(ByVal str As String) As Boolean
On Error GoTo IsHex_Error
IsHex = (WorksheetFunction.Hex2Dec(str) <> vbNullString)
On Error GoTo 0
Exit Function
IsHex_Error:
End Function
Public Function IsBoolean(ByVal str As String) As Boolean
IsBoolean = CBool((str = "$00") Or (str = "$01"))
End Function
Public Function IsPercentage(ByVal str As String) As Boolean
IsPercentage = (Len(str) = 3 And Left(str, 1) = "$" And IsNumeric(Right(str, 2)))
End Function
Then some additional logic is needed, because $01 is both Boolean and Percentage. In this case, you can consider it Percentage. This is some kind of a mapper, following this business logic:
Public Function DetectType(str) As String
Select Case True
Case IsHex(str)
DetectType = "HEX!"
Case IsPercentage(str) And IsBoolean(str)
DetectType = "Boolean!"
Case IsPercentage(str)
DetectType = "Percentage!"
Case Else
DetectType = "ELSE!"
End Select
End Function

Related

How do I compare values in VBA?

I have this Sub. It is activated when pressing a button on a user form and is used to count one entry up. I have the total amount of entries in this data base stored in A1. There is another button used to count one entry down, it works just fine. They both have checks so they don't load entries that don't exist. Somehow this one doesn't work.
Private Sub ButtonRight_Click()
MsgBox TextBoxID.Value
MsgBox Cells(1, 1).Value
MsgBox (TextBoxID.Value < Cells(1, 1).Value)
If TextBoxID.Value < Cells(1, 1).Value Then
LoadEntry (TextBoxID.Value + 1)
End If
End Sub
The LoadEntry Sub is used in other places as well and it works. I have this output stuff with MsgBox for debugging. It gives the outputs 1, 2, false. So (1 < 2) = false.
For comparison here is the other one which works:
Private Sub ButtonLeft_Click()
If TextBoxID.Value > 1 Then
LoadEntry (TextBoxID.Value - 1)
End If
End Sub
The problem is implicit conversions.
Strings are compared as text, so "10" is smaller than "2" because it sorts alphabetically as such.
Debug.Print "10" > "2" ' output: False
The value of a TextBox control is always a String; in order to treat it as a numeric value you must first convert it to a numeric value - but only if it's legal to do so (e.g. "ABC" has no equivalent numeric value).
Moreover, a cell's value is a Variant that may contain a number or another value that can (will) correctly but implicitly convert to a numeric value, but it could also be a Variant/Error (e.g. #N/A, or #VALUE! errors) that will throw a type mismatch error every time you try to compare it to anything (other than another Variant/Error value), so the cell's value should also be validated and explicitly converted before it's compared:
Dim rawValue As String
rawValue = TextBoxID.Value
If IsNumeric(rawValue) Then
Dim numValue As Double
numValue = CDbl(rawValue)
Dim cellValue As Variant
cellValue = ActiveSheet.Cells(1, 1).Value
If IsNumeric(cellValue) Then
If numValue < CDbl(cellValue) Then
LoadEntry numValue + 1
End If
End If
End If
Note that unqualified, Cells is implicitly referring to whatever the ActiveSheet happens to be - if that isn't the intent, consider qualifying that member call with an explicit Worksheet object, e.g. Sheet1.Cells(1, 1). If it is intentional, consider qualifying it with ActiveSheet so that the code says what it does, and does what it says.
Comparing values of different types in VBA is not a simple task, the result of the comparison depends on the types of variables, the possibility of conversion to a number, etc. Variant variables are compared differently than "non-Variant" variables. See https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/comparison-operators
According to the documentation, the Value property of the TextBox object has a base type Variant (see https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/value-property-microsoft-forms).
Therefore, the result of comparing Variant/String (TextBox.Value with String) and Variant/Double (Cell.Value with number) - TextBox.Value is always larger than Cell.Value:
Private Sub CommandButton1_Click()
TextBox1.Value = "123"
[A1].Value = 9999
Debug.Print "TextBox1.Value = " & TextBox1.Value & ", Type is " & TypeName(TextBox1.Value)
Debug.Print "[A1].Value = " & [A1].Value & ", Type is "; TypeName([A1].Value)
Debug.Print "TextBox1.Value > [A1].Value : (" & TextBox1.Value & " > " & [A1].Value & ") is " & (TextBox1.Value > [A1].Value)
Me.Hide
End Sub
'Output:
'TextBox1.Value = 123, Type is String
'[A1].Value = 9999, Type is Double
'TextBox1.Value > [A1].Value : (123 > 9999) is True
Therefore, it is advisable before comparing:
reduce the types of compared values to one;
to handle errors of type conversion
Simple way is to use Val() function https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/val-function
Private Sub ButtonRight_Click()
If Val(TextBoxID.Value) < Val(Cells(1, 1).Value) Then
LoadEntry (TextBoxID.Value + 1)
End If
End Sub
Also for this purpose I propose to create a function:
Function getNumDef(v As Variant, Optional defV As Long = -1) As Long
getNumDef = defV 'inintially getNumDef set as defaul value
On Error Resume Next
getNumDef = CLng(v) ' if error occurs, getNumDef value remains defV
End Function
It can be applied in the following way:
Private Sub ButtonRight_Click()
Dim TBV as Long, CV as Long
TBV = getNumDef(TextBoxID.Value) 'Type conversion and error handling
CV = getNumDef(Cells(1, 1).Value) 'Type conversion and error handling
If TBV < 0 Or CV < 0 Then
MsgBox "Some of the values are not numeric or less than 0" _
& vbCrLf & "Check the raw data", vbCritical + vbOKOnly, "Sub ButtonRight_Click()"
Else
If TBV < CV Then
'The parentheses in `LoadEntry (TextBoxID.Value + 1)` are syntax sugar,
' i.e. the argument `TextBoxID.Value + 1` in parentheses is passed as ByVal.
'If the argument without (), i.e. `LoadEntry TextBoxID.Value + 1`,
'it is passed as described in the Sub definition or the default ByRef
LoadEntry TextBoxID.Value + 1
End If
End If
End Sub

Application.Match not exact value

Have a piece of code that looks for matches between 2 sheets (sheet1 is customer list and rData is copied pdf with invoices). It usually is exact match but in some cases I'm looking for 6 first characters that matches rData
Dim rData As Variant
Dim r As Variant
Dim r20 As Variant
Dim result As Variant
Dim i As Long
rData = ActiveWorkbook.Sheets(2).Range("A1:A60000")
r20 = ActiveWorkbook.Sheets(1).Range("C2:C33")
For Each r In r20
result = Application.Match(r, rData, 0)
If Not IsError(result) Then
For i = 1 To 5
If (result - i) > 0 Then
If (Left(Trim(rData(result - i, 1)), 3) = "418") Then
MsgBox "customer: " & r & ". invoice: " & rData(result - i, 1)
End If
End If
Next
For i = 1 To 15
If (result + i) > 0 Then
If (Left(Trim(rData(result + i, 1)), 3) = "418") Then
MsgBox "customer: " & r & ". invoice: " & rData(result + i, 1)
End If
End If
Next
End If
Next r
End Sub
Only part of this that is giving me a headache is this part result = Application.Match(r, rData, 0). How do it get match for not exact match?
Sample of Sheet1
This is what more or less looks like. Matching after CustomerNumber# is easy because they are the same every invoice. BUT sometimes invoice does not have it so I'm searching after CustomerName and sometimes they have uppercase letters, sometimes there is extra stuff behind it and therefore it cannot find exact match.
Hope it makes sense.
To match the customer name from your customer list to the customer name in the invoice even if it has extra characters appended, you can use the wildcard * in Match().
You also have a typo in the Match() function. r20 should be rData.
This is your code with the fixes applied:
Sub Test()
'v4
Dim rData As Variant
Dim r As Variant
Dim r20 As Variant
Dim result As Variant
Dim i As Long
rData = ActiveWorkbook.Sheets(2).Range("A1:A60000")
r20 = ActiveWorkbook.Sheets(1).Range("C2:C33")
For Each r In r20
result = Application.Match(r & "*", rData, 0) ' <~ Fixed here
If Not IsError(result) Then
For i = 1 To 5
If (result - i) > 0 Then
If (Left(Trim(rData(result - i, 1)), 3) = "418") Then
MsgBox "customer: " & r & ". invoice: " & rData(result - i, 1)
End If
End If
Next
For i = 1 To 15
If (result + i) > 0 Then
If (Left(Trim(rData(result + i, 1)), 3) = "418") Then
MsgBox "customer: " & r & ". invoice: " & rData(result + i, 1)
End If
End If
Next
End If
Next r
End Sub
Notes:
Match() is case insensitive, so it works with different capitalisations.
The data in Sheets(2) must all be text for Match() to work correctly with wildcards.
EDIT1: New better version
EDIT2: Refactored constants and made data ranges dynamic
EDIT3: Allows for any prefix to an invoice number of a fixed length
The following is a better, rewritten version of your code:
Sub MuchBetter()
'v3
Const s_InvoiceDataWorksheet As String = "Sheet2"
Const s_InvoiceDataColumn As String = "A:A"
Const s_CustomerWorksheet As String = "Sheet1"
Const s_CustomerStartCell As String = "C2"
Const s_InvoiceNumPrefix As String = "418"
Const n_InvoiceNumLength As Long = 8
Const n_InvScanStartOffset As Long = -5
Const n_InvScanEndOffset As Long = 15
Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction ' Shortcut
With Worksheets(s_InvoiceDataWorksheet).Range(s_InvoiceDataColumn)
With .Parent.Range(.Cells(1), .Cells(Cells.Rows.Count).End(xlUp))
Dim varInvoiceDataArray As Variant
varInvoiceDataArray = ƒ.Transpose(.Cells.Value2)
End With
End With
With Worksheets(s_CustomerWorksheet).Range(s_CustomerStartCell)
With .Parent.Range(.Cells(1), .EntireColumn.Cells(Cells.Rows.Count).End(xlUp))
Dim varCustomerArray As Variant
varCustomerArray = ƒ.Transpose(.Cells.Value2)
End With
End With
Dim varCustomer As Variant
For Each varCustomer In varCustomerArray
Dim dblCustomerIndex As Double
dblCustomerIndex = Application.Match(varCustomer & "*", varInvoiceDataArray, 0)
If Not IsError(dblCustomerIndex) _
And varCustomer <> vbNullString _
Then
Dim i As Long
For i = ƒ.Max(dblCustomerIndex + n_InvScanStartOffset, 1) _
To ƒ.Min(dblCustomerIndex + n_InvScanEndOffset, UBound(varInvoiceDataArray))
Dim strInvoiceNum As String
strInvoiceNum = Right$(Trim$(varInvoiceDataArray(i)), n_InvoiceNumLength)
If (Left$(strInvoiceNum, Len(s_InvoiceNumPrefix)) = s_InvoiceNumPrefix) Then
MsgBox "customer: " & varCustomer & ". invoice: " & strInvoiceNum
End If
Next
End If
Next varCustomer
End Sub
Notes:
It is a good idea to use constants so all literal values are typed once only and kept grouped together.
Using the RVBA naming convention greatly increases the readability of the code, and reduces the likelihood of bugs.
Using long, appropriately named variables makes the code essentially self-documenting.
Using .Value2 whenever reading cell values is highly recommended (it avoids implicit casting, making it slightly faster as well as eliminating certain issues caused by the casting ).
Surprisingly, in VBA there are good reasons to put a variable declaration as close as possible to the first use of the variable. Two such reasons are 1) it improves readability, and 2) it simplifies future refactoring. Just remember that the variable is not reinitialised every time the Dim is encountered. Initialisation only occurs the first time.
The twin loops have been rolled into one according to the DRY principle.
Whilst the check for an empty customer name/number is not strictly necessary if you can guarantee it will never be so, it is good defensive programming as an empty value will cause erroneous results.
The negative index check inside the loop has been removed and replaced with the one-time use of the Max() worksheet function in the For statement.
The Min() worksheet function is also used in the For statement to avoid trying to read past the end of the array.
Always use worksheet functions on the WorksheetFunction object unless you are explicitly checking for errors, in which case use the Application object.

Excel if cell contain "-" near number then move

What I need to do is to basically write lessons number. There are 3 colomns.
The second column is running by a custom formula called LessonsLeft done by someone from my second thread on stackoverflow and it is
Function LessonsLeft(rng As Range) As String
If rng.Count > 1 Then Exit Function
Dim spltStr() As String
Dim i As Long
spltStr = Split(rng.Value, ",")
LessonsLeft = ",1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,"
For i = LBound(spltStr) To UBound(spltStr)
LessonsLeft = Replace(LessonsLeft, "," & spltStr(i) & ",", ",")
Next i
LessonsLeft = Mid(LessonsLeft, 2, Len(LessonsLeft) - 2)
End Function
What I need to do is to add another, third colomn which is for lessons that my students did their first attempt but they couldnt pass exam.
How i want the data to be there, is to write for exemple a "-" or "+" near a number in first column so the number will move to third column.
How can it be done ?
use this function
Function LessonsAttemptedButNotDone(rng As Range) As String
If rng.Count > 1 Then Exit Function
Dim spltStr() As String, lessonDone As String
Dim i As Long
spltStr = Split(rng.Value, ",")
For i = LBound(spltStr) To UBound(spltStr)
lessonDone = spltStr(i)
If Right(lessonDone, 1) = "-" Then
lessonDone = Left(lessonDone, Len(lessonDone) - 1)
LessonsAttemptedButNotDone = LessonsAttemptedButNotDone & lessonDone & ","
End If
Next
If LessonsAttemptedButNotDone <> "" Then LessonsAttemptedButNotDone = Left(LessonsAttemptedButNotDone, Len(LessonsAttemptedButNotDone) - 1)
End Function

Type mismatch error using custom class subroutine in Excel VBA

Working in Excel VBA, I have a class module where I define my class 'Marker'. One of the properties of my class is TextLine(), which is an array that holds up to 5 strings. I have defined the two methods below in my class module. In another (regular) module, I fill markerArr() with my custom Marker objects. Loading each object's properties with data at each array index is working fine... However, after loading data into the object at each index, I try to use markerArr(count).ProcessLines but receive a type mismatch error. Since ProcessLines is a public sub in my class module, and markerArr(count) contains a Marker object, I can't seem to understand why this error is occurring... Am I overlooking something obvious?
'Serial number replacement processing function
Public Sub ProcessLines()
Dim strSerial As String
Dim toggle As Boolean
toggle = False
Dim i As Integer
For i = 0 To 4
If Trim(m_TxtLines(i)) <> "" Then
'Add linefeed char to non-empty text lines
m_TxtLines(i) = m_TxtLines(i) & Chr(10)
'Detect if it is a serialized line
If InStr(1, m_TxtLines(i), "XXXXXX-YYY") > 0 Then
m_Serial(i) = True
toggle = True
End If
End If
Next
'When at least one line on the marker is serialized, create and replace serial text
If toggle = True Then
'Only prompt for input once
If startSerNo < 1 And Num_Sers < 1 Then
startSerNo = InputBox("Enter the serial number to start printing at." & Chr(10) & _
"Entering 1 will result in -001, entering 12 will result in -012, etc.", "Starting Serial #", "1")
Num_Sers = InputBox("Enter the amount of serializations to perform." & Chr(10) & _
"This will control how many copies of the entire marker set are printed.", "Total Serializations", "1")
End If
strSerial = CreateSerial(startSerNo)
Dim j As Integer
For j = 0 To 4
If m_Serial(j) Then
m_TxtLines(j) = Replace(m_TxtLines(j), "XXXXXX-YYY", strSerial)
End If
Next
End If
End Sub
'Creates the string to replace XXXXXX-YYY by concatenating the SFC# with the starting serial number
Private Function CreateSerial(ByVal startNum As Integer)
Dim temp
temp = SFC_Num
Select Case Len(CStr(startNum))
Case 1
temp = temp & "-00" & startNum
Case 2
temp = temp & "-0" & startNum
Case 3
temp = temp & "-" & startNum
Case Else
temp = temp & "-001"
End Select
CreateSerial = temp
End Function
Your CreateSerial function takes an integer as a parameter, but you are attempting to pass a string. I've pointed out some problems:
If startSerNo < 1 And Num_Sers < 1 Then 'Here I assume, you have these semi-globals as a variant - you are using numeric comparison here
startSerNo = InputBox("Enter the serial number to start printing at." & Chr(10) & _
"Entering 1 will result in -001, entering 12 will result in -012, etc.", "Starting Serial #", "1") 'Here startSerNo is returned as a string from the inputbox
Num_Sers = InputBox("Enter the amount of serializations to perform." & Chr(10) & _
"This will control how many copies of the entire marker set are printed.", "Total Serializations", "1") 'here Num_Sers becomes a String too
End If
strSerial = CreateSerial(startSerNo) 'here you are passing a String to the CreateSerial function. Either pass an integer, or allow a variant as parameter to CreateSerial
'......more code.....
Private Function CreateSerial(ByVal startNum As Integer)

VBA string interpolation syntax

What is the VBA string interpolation syntax? Does it exist?
I would to to use Excel VBA to format a string.
I have a variable foo that I want to put in a string for a range.
Dim row as Long
row = 1
myString = "$row:$row"
I would like the $row in the string to be interpolated as "1"
You could also build a custom Format function.
Public Function Format(ParamArray arr() As Variant) As String
Dim i As Long
Dim temp As String
temp = CStr(arr(0))
For i = 1 To UBound(arr)
temp = Replace(temp, "{" & i - 1 & "}", CStr(arr(i)))
Next
Format = temp
End Function
The usage is similar to C# except that you can't directly reference variables in the string. E.g. Format("This will {not} work") but Format("This {0} work", "will").
Public Sub Test()
Dim s As String
s = "Hello"
Debug.Print Format("{0}, {1}!", s, "World")
End Sub
Prints out Hello, World! to the Immediate Window.
This works well enough, I believe.
Dim row as Long
Dim s as String
row = 1
s = "$" & row & ":$" & row
Unless you want something similar to Python's or C#'s {} notation, this is the standard way of doing it.
Using Key\Value Pairs
Another alternative to mimic String interpolation is to pass in key\value pairs as a ParamArray and replace the keys accordingly.
One note is that an error should be raised if there are not an even number of elements.
' Returns a string that replaced special keys with its associated pair value.
Public Function Inject(ByVal source As String, ParamArray keyValuePairs() As Variant) As String
If (UBound(keyValuePairs) - LBound(keyValuePairs) + 1) Mod 2 <> 0 Then
Err.Raise 5, "Inject", "Invalid parameters: expecting key/value pairs, but received an odd number of arguments."
End If
Inject = source
' Replace {key} with the pairing value.
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
Inject = Replace(Inject, "{" & keyValuePairs(index) & "}", keyValuePairs(index + 1), , , vbTextCompare)
Next index
End Function
Simple Example
Here is a simple example that shows how to implement it.
Private Sub testingInject()
Const name As String = "Robert"
Const age As String = 31
Debug.Print Inject("Hello, {name}! You are {age} years old!", "name", name, "age", age)
'~> Hello, Robert! You are 31 years old!
End Sub
Although this may add a few extra strings, in my opinion, this makes it much easier to read long strings.
See the same simple example using concatenation:
Debug.Print "Hello, " & name & "! You are " & age & " years old!"
Using Scripting.Dicitionary
Really, a Scripting.Dictionary would be perfect for this since they are nothing but key/value pairs. It would be a simple adjustment to my code above, just take in a Dictionary as the parameter and make sure the keys match.
Public Function Inject(ByVal source As String, ByVal data As Scripting.Dictionary) As String
Inject = source
Dim key As Variant
For Each key In data.Keys
Inject = Replace(Inject, "{" & key & "}", data(key))
Next key
End Function
Dictionary example
And the example of using it for dictionaries:
Private Sub testingInject()
Dim person As New Scripting.Dictionary
person("name") = "Robert"
person("age") = 31
Debug.Print Inject("Hello, {name}! You are {age} years old!", person)
'~> Hello, Robert! You are 31 years old!
End Sub
Additional Considerations
Collections sound like they would be nice as well, but there is no way of accessing the keys. It would probably get messier that way.
If using the Dictionary method you might create a simple factory function for easily creating Dictionaries. You can find an example of that on my Github Library Page.
To mimic function overloading to give you all the different ways you could create a main Inject function and run a select statement within that.
Here is all the code needed to do that if need be:
Public Function Inject(ByVal source As String, ParamArray data() As Variant) As String
Dim firstElement As Variant
assign firstElement, data(LBound(data))
Inject = InjectCharacters(source)
Select Case True
Case TypeName(firstElement) = "Dictionary"
Inject = InjectDictionary(Inject, firstElement)
Case InStr(source, "{0}") > 0
Inject = injectIndexes(Inject, CVar(data))
Case (UBound(data) - LBound(data) + 1) Mod 2 = 0
Inject = InjectKeyValuePairs(Inject, CVar(data))
Case Else
Err.Raise 5, "Inject", "Invalid parameters: expecting key/value pairs or Dictionary or an {0} element."
End Select
End Function
Private Function injectIndexes(ByVal source As String, ByVal data As Variant)
injectIndexes = source
Dim index As Long
For index = LBound(data) To UBound(data)
injectIndexes = Replace(injectIndexes, "{" & index & "}", data(index))
Next index
End Function
Private Function InjectKeyValuePairs(ByVal source As String, ByVal keyValuePairs As Variant)
InjectKeyValuePairs = source
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
InjectKeyValuePairs = Replace(InjectKeyValuePairs, "{" & keyValuePairs(index) & "}", keyValuePairs(index + 1))
Next index
End Function
Private Function InjectDictionary(ByVal source As String, ByVal data As Scripting.Dictionary) As String
InjectDictionary = source
Dim key As Variant
For Each key In data.Keys
InjectDictionary = Replace(InjectDictionary, "{" & key & "}", data(key))
Next key
End Function
' QUICK TOOL TO EITHER SET OR LET DEPENDING ON IF ELEMENT IS AN OBJECT
Private Function assign(ByRef variable As Variant, ByVal value As Variant)
If IsObject(value) Then
Set variable = value
Else
Let variable = value
End If
End Function
End Function
Private Function InjectCharacters(ByVal source As String) As String
InjectCharacters = source
Dim keyValuePairs As Variant
keyValuePairs = Array("n", vbNewLine, "t", vbTab, "r", vbCr, "f", vbLf)
If (UBound(keyValuePairs) - LBound(keyValuePairs) + 1) Mod 2 <> 0 Then
Err.Raise 5, "Inject", "Invalid variable: expecting key/value pairs, but received an odd number of arguments."
End If
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Global = True
' Replace is ran twice since it is possible for back to back patterns.
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
RegEx.Pattern = "((?:^|[^\\])(?:\\{2})*)(?:\\" & keyValuePairs(index) & ")+"
InjectCharacters = RegEx.Replace(InjectCharacters, "$1" & keyValuePairs(index + 1))
InjectCharacters = RegEx.Replace(InjectCharacters, "$1" & keyValuePairs(index + 1))
Next index
End Function
I have a library function SPrintF() which should do what you need.
It replaces occurrences of %s in the supplied string with an extensible number of parameters, using VBA's ParamArray() feature.
Usage:
SPrintF("%s:%s", 1, 1) => "1:1"
SPrintF("Property %s added at %s on %s", "88 High St, Clapham", Time, Date) => ""Property 88 High St, Clapham added at 11:30:27 on 25/07/2019"
Function SprintF(strInput As String, ParamArray varSubstitutions() As Variant) As String
'Formatted string print: replaces all occurrences of %s in input with substitutions
Dim i As Long
Dim s As String
s = strInput
For i = 0 To UBound(varSubstitutions)
s = Replace(s, "%s", varSubstitutions(i), , 1)
Next
SprintF = s
End Function
Just to add as a footnote, the idea for this was inspired by the C language printf function.
I use a similar code to that of #natancodes except that I use regex to replace the occurances and allow the user to specifiy description for the placeholders. This is useful when you have a big table (like in Access) with many strings or translations so that you still know what each number means.
Function Format(ByVal Source As String, ParamArray Replacements() As Variant) As String
Dim Replacement As Variant
Dim i As Long
For i = 0 To UBound(Replacements)
Dim rx As New RegExp
With rx
.Pattern = "{" & i & "(?::(.+?))?}"
.IgnoreCase = True
.Global = True
End With
Select Case VarType(Replacements(i))
Case vbObject
If Replacements(i) Is Nothing Then
Dim Matches As MatchCollection
Set Matches = rx.Execute(Source)
If Matches.Count = 1 Then
Dim Items As SubMatches: Set Items = Matches(0).SubMatches
Dim Default As String: Default = Items(0)
Source = rx.Replace(Source, Default)
End If
End If
Case vbString
Source = rx.Replace(Source, CStr(Replacements(i)))
End Select
Next
Format = Source
End Function
Sub TestFormat()
Debug.Print Format("{0:Hi}, {1:space}!", Nothing, "World")
End Sub