I'm struggling with VBA code. I'm working on a ID code generator program. One of the processes involves Split Company Names by words, and taking the first two words. Split has proved to be useful in this tasks, however, when in dealing with Company Names shorter than 2 words I've got a #VALUE! Error.
One way I tried to fix it, was using the ISERROR function, so if I get any error it replaces it with a character, say "X".
In summary, what I'm trying is to capture only the second Word of the Name, if there is no second Word, just display "X".
Public Function idcode_2(text As String) As String
Dim Arr_text As Variant
Dim rz_x, rz2, code As String
Dim i As Integer
Dim c
Arr_text = Split(text, " ", 3)
rz2 = Arr_text(1)
If IsError(rz2) = True Then
rz2 = "X"
Else
rz2 = rz2 & ""
End If
idcode_2 = rz2
End Function
I'm using VBA in Excel - Microsoft Office Professional Plus 2013.
Arr_text will be a zero-based array - UBound(Arr_text) will give you the upper bound of that array (zero if one item, one if two items, etc)
Public Function idcode_2(text As String) As String
Dim Arr_text As Variant, rz2
Arr_text = Split(text, " ", 3)
If UBound(Arr_text ) > 0 Then
rz2 = Arr_text(1)
Else
rz2 = "x"
End If
idcode_2 = rz2
End Function
Public Function idcode_2(text As String) As String
If Instr(text, " ") > 0 Then
idcode = Split(text)(1)
Else
idcode = "x"
End If
End Function
Related
I have a VBA code that's designed to search a CSV String and add Carriage Returns where they should exist. I've split it up into two seperate functions - one to search the string and put the index of where the CRs should go into an array and a second function to actually add the CRs.
The issue I'm running into is that the value in the immediate window/in the watch window for the functions is correct within the function itself, but it assigns the result variable a blank string.
'*****************Import CSV**********************
'Took this straight off the internet because it was reading Jet.com files as one single line
'
Sub ImportCSVFile(filepath As String)
.....
line = SearchString(line, "SALE")
.....
End Sub
'****************Search String***************************
'This is search the string for something - It will then call a function to insert carriage returns
Function SearchString(source As String, target As String) As String
Dim i As Integer
Dim k As Integer
Dim myArray() As Variant
Dim resultString As String
Do
i = i + 1
If Mid(source, i, Len(target)) = target Then
ReDim Preserve myArray(k)
myArray(k) = i
k = k + 1
End If
DoEvents
Loop Until i = Len(source)
resultString = addCarriageReturns(source, myArray) 'resultString here is assigned a blank string
SearchString = resultString
End Function
'***************Add Carraige Returns**************************
'Cycle through the indices held in the array and place carriage returns into the string
Function addCarriageReturns(source As String, myArray As Variant) As String
Dim i As Integer
Dim resultString As String
resultString = source
For i = 0 To UBound(myArray, 1)
resultString = Left(resultString, myArray(i) + i) & Chr(13) & Right(resultString, Len(resultString) - myArray(i) + i)
Next i
addCarraigeReturns = resultString 'The value of addCarriageReturn is correct in the immediate window here
End Function
In the function the value is not blank
...but when it passes it back, it says the value is blank
I'm just curious, why do you want separate functions like this?
Can you just use:
line = Replace(line, "SALE", "SALE" & Chr(13))
What I want to do is replace all 'A' in a string with "Bb". but it will only loop with the original string not on the new string.
for example:
AAA
BbAA
BbBbA
and it stops there because the original string only has a length of 3. it reads only up to the 3rd index and not the rest.
Dim txt As String
txt = output_text.Text
Dim a As String = a_equi.Text
Dim index As Integer = txt.Length - 1
Dim output As String = ""
For i = 0 To index
If (txt(i) = TextBox1.Text) Then
output = txt.Remove(i, 1).Insert(i, a)
txt = output
TextBox2.Text += txt + Environment.NewLine
End If
Next
End Sub
I think this leaves us looking for a String.ReplaceFirst function. Since there isn't one, we can just write that function. Then the code that calls it becomes much more readable because it's quickly apparent what it's doing (from the name of the function.)
Public Function ReplaceFirst(searched As String, target As String, replacement As String) As String
'This input validation is just for completeness.
'It's not strictly necessary.
'If the searched string is "null", throw an exception.
If (searched Is Nothing) Then Throw New ArgumentNullException("searched")
'If the target string is "null", throw an exception.
If (target Is Nothing) Then Throw New ArgumentNullException("target")
'If the searched string doesn't contain the target string at all
'then just return it - were done.
Dim foundIndex As Integer = searched.IndexOf(target)
If (foundIndex = -1) Then Return searched
'Build a new string that replaces the target with the replacement.
Return String.Concat(searched.Substring(0, foundIndex), replacement, _
searched.Substring(foundIndex + target.Length, searched.Length - (foundIndex + target.Length)))
End Function
Notice how when you read the code below, you don't even have to spend a moment trying to figure out what it's doing. It's readable. While the input string contains "A", replace the first "A" with "Bb".
Dim input as string = "AAA"
While input.IndexOf("A") > -1
input = input.ReplaceFirst(input,"A","Bb")
'If you need to capture individual values of "input" as it changes
'add them to a list.
End While
You could optimize or completely replace the function. What matters is that your code is readable, someone can tell what it's doing, and the ReplaceFirst function is testable.
Then, let's say you wanted another function that gave you all of the "versions" of your input string as the target string is replaced:
Public Function GetIterativeReplacements(searched As String, target As String, replacement As String) As List(of string)
Dim output As New List(Of String)
While searched.IndexOf(target) > -1
searched = ReplaceFirst(searched, target, replacement)
output.Add(searched)
End While
Return output
End Function
If you call
dim output as List(of string) = GetIterativeReplacments("AAAA","A","Bb")
It's going to return a list of strings containing
BbAAA, BbBbAA, BbBbBbA, BbBbBbBb
It's almost always good to keep methods short. If they start to get too long, just break them into smaller methods with clear names. That way you're not trying to read and follow and test one big, long function. That's difficult whether or not you're a new programmer. The trick isn't being able to create long, complex functions that we understand because we wrote them - it's creating small, simpler functions that anyone can understand.
Check your comments for a better solution, but for future reference you should use a while loop instead of a for loop if your condition will be changing and you're wanting to take that change into account.
I've made a simple example below to help you understand. If you tried the same with a for loop, you'd only get "one" "two" and "three" printed because the for loop doesn't 'see' that vals was changed
Dim vals As New List(Of String)
vals.Add("one")
vals.Add("two")
vals.Add("three")
Dim i As Integer = 0
While i < vals.Count
Console.WriteLine(vals(i))
If vals(i) = "two" Then
vals.Add("four")
vals.Add("five")
End If
i += 1
End While
If you do want to replace one by one instead of using the Replace function, you could use a while loop to look for the index of your search character/string, and then replace/insert at that index.
Sub Main()
Dim a As String = String.Empty
Dim b As String = String.Empty
Dim c As String = String.Empty
Dim d As Int32 = -1
Console.Write("Whole string: ")
a = Console.ReadLine()
Console.Write("Replace: ")
b = Console.ReadLine()
Console.Write("Replace with: ")
c = Console.ReadLine()
d = a.IndexOf(b)
While d > -1
a = a.Remove(d, b.Length)
a = a.Insert(d, c)
d = a.LastIndexOf(b)
End While
Console.WriteLine("Finished string: " & a)
Console.ReadLine()
End Sub
Output would look like this:
Whole string: This is A string for replAcing chArActers.
Replace: A
Replace with: Bb
Finished string: This is Bb string for replBbcing chBbrBbcters.
I was going to write a while loop to answer your question, but realized (with assistance from others) that you could just .replace(x,y)
Output.Text = Input.Text.Replace("A", "Bb")
'Input = N A T O
'Output = N Bb T O
Edit: There is probably a better alternative, but i quickly jotted this loop down, hope it helps.
You've said your new and don't fully understand while loops. So if you don't understand functions either or how to pass arguments to them, I'd suggest looking that up too.
This is your Event, It can be a Button click or Textbox text change.
'Cut & Paste into an Event (Change textboxes to whatever you have input/output)
Dim Input As String = textbox1.Text
Do While Input.Contains("A")
Input = ChangeString(Input, "A", "Bb")
' Do whatever you like with each return of ChangeString() here
Loop
textbox2.Text = Input
This is your Function, with 3 Arguments and a Return Value that can be called in your code
' Cut & Paste into Code somewhere (not inside another sub/Function)
Private Function ChangeString(Input As String, LookFor As Char, ReplaceWith As String)
Dim Output As String = Nothing
Dim cFlag As Boolean = False
For i As Integer = 0 To Input.Length - 1
Dim c As Char = Input(i)
If (c = LookFor) AndAlso (cFlag = False) Then
Output += ReplaceWith
cFlag = True
Else
Output += c
End If
Next
Console.WriteLine("Output: " & Output)
Return Output
End Function
I am trying to remove words appearing in one string from a different string using a custom function. For instance:
A1:
the was why blue hat
A2:
the stranger wanted to know why his blue hat was turning orange
The ideal outcome in this example would be:
A3:
stranger wanted to know his turning orange
I need to have the cells in reference open to change so that they can be used in different situations.
The function will be used in a cell as:
=WORDREMOVE("cell with words needing remove", "cell with list of words being removed")
I have a list of 20,000 rows and have managed to find a custom function that can remove duplicate words (below) and thought there may be a way to manipulate it to accomplish this task.
Function REMOVEDUPEWORDS(txt As String, Optional delim As String = " ") As String
Dim x
'Updateby20140924
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each x In Split(txt, delim)
If Trim(x) <> "" And Not .exists(Trim(x)) Then .Add Trim(x), Nothing
Next
If .Count > 0 Then REMOVEDUPEWORDS = Join(.keys, delim)
End With
End Function
If you can guarantee that your words in both strings will be separated by spaces (no comma, ellipses, etc), you could just Split() both strings then Filter() out the words:
Function WORDREMOVE(ByVal strText As String, strRemove As String) As String
Dim a, w
a = Split(strText) ' Start with all words in an array
For Each w In Split(strRemove)
a = Filter(a, w, False, vbTextCompare) ' Remove every word found
Next
WORDREMOVE = Join(a, " ") ' Recreate the string
End Function
You can also do this using Regular Expressions in VBA. The version below is case insensitive and assumes all words are separated only by space. If there is other punctuation, more examples would aid in crafting an appropriate solution:
Option Explicit
Function WordRemove(Str As String, RemoveWords As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.ignorecase = True
.Global = True
.Pattern = "(?:" & Join(Split(WorksheetFunction.Trim(RemoveWords)), "|") & ")\s*"
WordRemove = .Replace(Str, "")
End With
End Function
My example is certainly not the best code, but it should work
Function WORDREMOVE(FirstCell As String, SecondCell As String)
Dim FirstArgument As Variant, SecondArgument As Variant
Dim FirstArgumentCounter As Integer, SecondArgumentCounter As Integer
Dim Checker As Boolean
WORDREMOVE = ""
FirstArgument = Split(FirstCell, " ")
SecondArgument = Split(SecondCell, " ")
For SecondArgumentCounter = 0 To UBound(SecondArgument)
Checker = False
For FirstArgumentCounter = 0 To UBound(FirstArgument)
If SecondArgument(SecondArgumentCounter) = FirstArgument(FirstArgumentCounter) Then
Checker = True
End If
Next FirstArgumentCounter
If Checker = False Then WORDREMOVE = WORDREMOVE & SecondArgument(SecondArgumentCounter) & " "
Next SecondArgumentCounter
WORDREMOVE = Left(WORDREMOVE, Len(WORDREMOVE) - 1)
End Function
I have written the following function to read all unique values from cells in a range and create a comma separated string from them? Is there a better, simpler way to do this?
Private Sub CsvUniqueValues(r As Excel.Range)
Dim c As Excel.Range
Dim s As String = ""
For Each c In r.Cells
If ExcelApp.WorksheetFunction.CountIf(r, c.Value) = 1 Then
s = s & ","
End If
Next
If s.Length > 0 Then
s = s.Substring(0, s.Length - 1)
End If
End Sub
You could use LINQ to get a list of only the unique values, like this:
Dim uniqueValues As IEnumerable = r.Cells.Where(Function(x) ExcelApp.WorksheetFunction.CountIf(r, x.Value) = 1))
Then, you could use LINQ to convert all of those unique values to strings:
Dim uniqueStrings As IEnumerable(Of String) = uniqueValues.Select(Of String)(Function(x) x.ToString())
Then you can use LINQ to convert the resulting list to an array:
Dim uniqueArray() As String = uniqueStrings.ToArray()
Then, you could use the String.Join method to combine them into a single CSV string:
Dim csv As String = String.Join(",", uniqueArray)
You could, of course, do all of this in a single command, like this:
Dim csv As String = String.Join(",",
r.Cells.Where(Function(x) ExcelApp.WorksheetFunction.CountIf(r, x.Value) = 1))
.Select(Of String)(Function(x) x.ToString())
.ToArray())
The question, though, is whether or not you would call that "easier". LINQ is useful because it makes code easier to to read and write, but when it's taken too far, it can become less readable, thereby defeating the purpose of using it. At the very least, to make your code more clear, I would move the first part into a named function so it's more self-documenting:
Public Function GetUniqueCellValuesAsString(r As Excel.Range) As IEnumerable(Of String)
Return r.Cells.Where(
Function(x) ExcelApp.WorksheetFunction.CountIf(r, x.Value) = 1))
.Select(Of String)(Function(x) x.ToString())
End Function
Then you could just build the CSV string like this:
Dim csv As String = String.Join(",", GetUniqueCellValuesAsString(r).ToArray())
I would make use of the collection object. Since collections can only contain unique values, trying to add all of your input data to a collection will result in an array of unique values. The following modification lets CsvUniqueValues return a comma separated string from the values in any given range.
'Test function and return result in MsgBox
Sub ReturnUnique()
MsgBox CsvUniqueValues(Selection)
End Sub
'Function will return csv-string from input range
Function CsvUniqueValues(r As Range) As String
Dim Cell As Range
Dim i As Integer
Dim DistCol As New Collection
Dim s As String
'Add all distinct values to collection
On Error Resume Next
For Each Cell In r
DistCol.Add Cell.Value, Cell.Value
Next Cell
On Error GoTo 0
'Write collection to comma seperated list
For i = 1 To DistCol.Count
s = s & DistCol.Item(i) & "; "
Next i
s = Left(s, Len(s) - 2)
CsvUniqueValues = s
End Function
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