I have a formula to swap last names with first names in cells where the format is "Smith, John".
=MID(A4&" "&A4,(FIND(" ",A4)+1),(LEN(A4)-1))
I created a function to utilize this functionality and it seemed to work at first. The function is:
Function SwapNames(text As String) As String
SwapNames = Mid(text & " " & text, (Find(" ", text) - 1, (Len(text) - 1))
End Function
I converted my workbook to an Add-In filetype so I could use this globally and now it says the Find function is undefined. What am I doing wrong here?
As #Nathan_Sav said - use split, and perhaps an optional argument to identify the delimiter.
So =swapnames("Bartrup-Cook Darren") returns "Darren Bartrup-Cook" and =swapnames("Bartrup-Cook Darren","-") returns "Cook Darren Bartrup" a #REF! error is returned if the delimiter isn't present in the string.
Function SwapNames(text As String, Optional Delimiter As String = " ") As Variant
Dim SplitAt As Long
Dim NamePart As Variant
SplitAt = InStr(text, Delimiter)
If SplitAt = 0 Then
SwapNames = CVErr(xlErrRef)
Else
NamePart = Split(text, Delimiter)
SwapNames = NamePart(1) & " " & NamePart(0)
End If
End Function
This is how you can use Split function and swap the name.
Function SwapNames(text As String) As String
SwapNames = Trim(Split(text, ",")(1)) & " " & Trim(Split(text, ",")(0))
End Function
So it will change Smith, John to John Smith and Smith, John J to John J Smith.
Related
I have the following function that finds words in a string, for instance searching for don will find Don and not don't which is what I want:
"I don't know Don, what do you think?"
I however also find I need to look for words like race, races, racing. I would like to be able to search for rac* to cover all such variants rather than searching for each.
Is it possible to update the code to do this? Or does someone have any code that can solved this problem?
Function InStrExact(Start As Long, SourceText As String, WordToFind As String, _
Optional CaseSensitive As Boolean = False)
Dim x As Long, Str1 As String, Str2 As String, Pattern As String
If CaseSensitive Then
Str1 = SourceText
Str2 = WordToFind
Pattern = "[!A-Za-z0-9]"
Else
Str1 = UCase(SourceText)
Str2 = UCase(WordToFind)
Pattern = "[!A-Z0-9]"
End If
For x = Start To Len(Str1) - Len(Str2) + 1
If Mid(" " & Str1 & " ", x, Len(Str2) + 2) Like Pattern & Str2 & Pattern _
And Not Mid(Str1, x) Like Str2 & "'[" & Mid(Pattern, 3) & "*" Then
InStrExact = x
Exit Function
End If
Next
End Function
A simple modification is to add a wildcard to the end of your search string and match against all remaining characters in the original string. The change is to replace this line:
If Mid(" " & Str1 & " ", x, Len(Str2) + 2) Like Pattern & Str2 & Pattern _
with this:
If Mid(" " & Str1 & " ", x) Like Pattern & Str2 & Pattern & "*" _
This simply removes the restriction on the number of characters to be matched. If a wildcard is added to the end of the search word, it comes before the trailing pattern and so allows any number of additional characters. If there is no wildcard in the search word, then the trailing pattern still needs to come immediately after the search word and hence still requires an exact match.
Note that there will be an issue if the word you're searching for is the last word AND you add a wildcard. The length of Str2 then causes the function to stop searching too soon. So the complete solution is to also replace this line:
For x = Start To Len(Str1) - Len(Str2) + 1
with this:
For x = Start To Len(Str1)
There's no need to stop checking any earlier.
I'd go like follows:
Function InStrExact(startPos As Long, sourceText As String, wordToFind As String, _
Optional CaseSensitive As Boolean = False) As Long
Dim x As Long
Dim actualSourceText As String, actualWordToFind As String, Pattern As String
Dim word As Variant
actualSourceText = Replace(Mid(sourceText, startPos), ",", "")
If CaseSensitive Then
Pattern = "[A-za-z]"
Else
actualSourceText = UCase(actualSourceText)
actualWordToFind = UCase(wordToFind)
Pattern = "[A-Z]"
End If
For Each word In Split(actualSourceText, " ")
If CStr(word) Like actualWordToFind & Pattern Or CStr(word) = actualWordToFind Then
InStrExact2 = x + 1
Exit Function
End If
x = x + Len(word) + 1
Next
InStrExact = -1 '<--| return -1 if no match
End Function
I'm rooky for VBA. I have some problem about reversing my data on VBA-Excel. My data is "3>8 , 6>15 , 26>41 (each data on difference cells)" that i could reverse "3>8" to "8>3" follow my requirement by using function reverse. But i couldn't reverse "6>15" and "26>41" to "15>6" and "41>26". It will be "51>6" and "14>62" that failure, I want to be "15>6" and "41>26".
Reverse = StrReverse(Trim(str))
Help me for solve my issue please and thank for comment.
You first need to find the position of the ">" in the cell. you do this by taking the contents of the cell and treating it as a String and finding the ">"
This is done in the line beginning arrowPosition. This is the integer value of the position of the ">" in you original string
Next use Left to extract the text up to the ">" and Right to extract the text after the ">"
Then build a new String of rightstr & ">" & leftStr.
Note I input my data from Sheet1 B5 but you can just use any source as long as it is a String in the correct format.
Sub Test()
Dim myString As String
myString = Sheets("Sheet1").Range("B5")
Debug.Print myString
Debug.Print reverseString(myString)
End Sub
Function reverseString(inputString As String) As String
Dim leftStr As String
Dim rightStr As String
Dim arrowPosition As Integer
arrowPosition = InStr(1, inputString, ">")
leftStr = Left(inputString, arrowPosition - 1)
rightStr = Right(inputString, Len(inputString) - arrowPosition)
reverseString = rightStr & ">" & leftStr
End Function
just because you look for a VBA, you can add this function into your code:
Function rev(t As String) As String
s = Split(t, ">", 2)
rev = s(1) & ">" & s(0)
End Function
of course only if you have to reverse 2 number, otherwise you'll loop the "s", but the function would lose its usefulness
Public Function SameStuff(s1 As String, s2 As String) As Boolean
Dim bad As Boolean
SameStuff = False
ary1 = Split(Replace(s1, " ", ""), ",")
ary2 = Split(Replace(s2, " ", ""), ",")
Length1 = UBound (ary1)
Length2 = UBound(ary2)
k=1
If Length1<= Length2 and Length1<>0 then
for i=0 to Length1-1
If ary1(i) = ary2(i) then
ary3(k,i) = ary1(i)
End If
Next i
k=k+1
else
Exit function
End If
End Function
Here I take value from Range("A1") - (has 3 words) and value of Range("A2") - (has 4 words). Split them both by finding space between words and store them in arrays. If length of one array is 3 and other is 4, 3 words from both the arrays will be compared. If 3 words are found to be same then Range("B1") and Range("B2") must both have the 3 word name i.e Range("A1").Value. I think this logic will work fine to find similar names like "ABC DEF HIJ " in A1 and "ABC DEF HIJ Limited" in A2.
I am not able to put it in code.
Word length will not remain the same i.e 3,4 .
Use a dictionary would be an easy alternative, you can use the .exists method to do this for you, you have to transfer the array (result of split() ) to a dictionary tho, but that's a loop, not too tricky. Or, you could leave one of the inputas as a string and split only 1, and use if strStringLeftAlone like "* " & strSection(x) & " *" or use instr, with the same idea as the search " " & strSection(x) & " " or find
This should work regardless how long the arrays are, i.e. no matter how many words (and spaces) there are in each of the strings to be compared. Notice I removed the k variable as it didn't seem to serve any purpose in the code. This solution does presuppose, however, that ONLY the LAST word in the two strings is different.
Public Function SameStuff(s1 As String, s2 As String) As Boolean
Dim sameBool As Boolean
Dim i As Long, Length1 As Long, Length2 As Long
Dim tempArr1 as String, tempArr2 as String
Dim ary1 as Variant, ary2 as Variant
ary1 = Split(Replace(s1, " ", ""), ",")
ary2 = Split(Replace(s2, " ", ""), ",")
Length1 = UBound (ary1)
Length2 = UBound(ary2)
If Length1 <= Length2 and Length1 > 0 then
For i=0 to Length1-1
tempArr1 = tempArr1 & ary1(i)
tempArr2 = tempArr2 & ary2(i)
Next i
If tempArr1 = tempArr2 then sameBool = True
End If
SameStuff = sameBool
End Function
Edit
Added some variable declarations to the code that I had forgotten, otherwise the code would not work with Option Explicit at the top of the module.
I want to take a name in First Last format and change it to Last, First. I know I could to this with a formula but I want to be complicated.
Please let me know if you see any red flags in my code, or suggestions for improvements.
Function LastFirst(Name_FL As String)
'This only works if there is a single space in the cell - Will Error If Spaces <> 1
Length = Len(Name_FL) 'Establishes Length of String
Spaces = Length - Len(Application.WorksheetFunction.Substitute(Name_FL, " ", "")) 'Number of spaces
If Spaces <> 1 Then
LastFirst = "#SPACES!#" 'Error Message
Else
SpaceLocation = Application.WorksheetFunction.Find(" ", Name_FL, 1) 'Location of space
Last = Right(Name_FL, Length - SpaceLocation) 'Establishes Last Name String
First = Left(Name_FL, SpaceLocation) 'Establishes First Name String
LastFirst = Application.WorksheetFunction.Proper(Last & ", " & First) 'Puts it together
End If
End Function 'Ta-da
You could simplify it to:
Function LastFirst(Name_FL As String) As String
If (Len(Name_FL) - Len(Replace(Name_FL, " ", ""))) > 1 Then
LastFirst = "#SPACES#"
Else
LastFirst = StrConv(Split(Name_FL, " ")(1) & ", " & Split(Name_FL, " ")(0), vbProperCase)
End If
End Function
The logic here is:
If there is more than 1 space, return the error string #SPACES#
If there is 1 space, the split the string using " " as a delimiter.
Use the second index of the Split array, add ", " and use the first index of the split array.
Use StrConv() to convert it all to proper case.
You might also want to add another check for no spaces:
If InStr(Name_FL, " ") > 0 Then
'// There is a space in the string
Else
'// There is no space in the string
End If
Which can also be tested for by slightly changing the logic of the above example:
Function LastFirst(Name_FL As String) As String
If (Len(Name_FL) - Len(Replace(Name_FL, " ", ""))) = 1 Then
LastFirst = StrConv(Split(Name_FL, " ")(1) & ", " & Split(Name_FL, " ")(0), vbProperCase)
Else
LastFirst = "#SPACES#"
End If
End Function
Further elaboration on functions:
You can see I've used some VBA functions here in place of your WorksheetFunction methods.
Len() returns the Length of a string.
Replace() does what it says on the tin - replaces a given string with another.
StrConv() Converts a String to a respective case (e.g. vbProperCase).
Split() Creates a zero-based single dimension array from a string, by Splitting it on a given delimiter.
Finally - Don't forget to specify a return value in your function header:
Function LastFirst(Name_FL As String)As String<~~ return type
I have a macro I am trying to turn into a VBA Function or Query for adding leading zeros to a field.
For my circumstances, their needs to be 4 numeric digits plus any alphabetic characters that follow so a simple format query doesn't do the trick.
The macro I have uses Evaluate and =Match but I am unsure how this could be achieved in Access.
Sub Change_Number_Format_In_String()
Dim iFirstLetterPosition As Integer
Dim sTemp As String
For Each c In Range("A2:A100")
If Len(c) > 0 Then
iFirstLetterPosition = Evaluate("=MATCH(TRUE,NOT(ISNUMBER(1*MID(" & c.Address & ",ROW($1:$20),1))),0)")
sTemp = Left(c, iFirstLetterPosition - 1) 'get the leading numbers
sTemp = Format(sTemp, "0000") 'format the numbers
sTemp = sTemp & Mid(c, iFirstLetterPosition, Len(c)) 'concatenate the remainder of the string
c.NumberFormat = "#"
c.Value = sTemp
End If
Next
End Sub
In my database the field in need of formatting is called PIDNUMBER
EDIT:
To expand on why FORMAT doesnt work in my situation. Some PIDNUMBERS have an alpha character after the number that should not be counted when determining how many zeroes to add.
In example:
12 should become 0012
12A should become 0012A
When using format, it counts the letters as part of the string, so 12A would become 012A instead of 0012A as intended.
You could try:
Public Function customFormat(ByRef sString As String) As String
customFormat = Right("0000" & sString, 4 + Len(sString) - Len(CStr(Val(sString))))
End Function
Try utilize this function, if you only want this to be available in VBA, put Private in front of the Function:
Function ZeroPadFront(oIn As Variant) As String
Dim zeros As Long, sOut As String
sOut = CStr(oIn)
zeros = 4 - Len(sOut)
If zeros < 0 Then zeros = 0
ZeroPadFront = String(zeros, "0") & sOut
End Function
The Val() function converts a string to a number, and strips off any trailing non-numeric characters. We can use it to figure out how many digits the numeric portion has:
Function PadAlpha$(s$)
Dim NumDigs As Long
NumDigs = Len(CStr(Val(s)))
If NumDigs < 4 Then
PadAlpha = String$(4 - NumDigs, "0") & s
Else
PadAlpha = s
End If
End Function
? padalpha("12")
> 0012
? padalpha("12a")
> 0012a
Bill,
See if this will work. It seems like a function would better suit you.
Function NewPIDNumber(varPIDNumber As Variant) As String
Dim lngLoop As Long
Dim strChar As String
For lngLoop = 1 to Len(varPIDNumber)
strChar = Mid(varPIDNumber, lngLoop, 1)
If IsNumeric(strChar) Then
NewPIDNumber = NewPIDNumber & strChar
Else
Exit For
End If
Next lngLoop
If Len(NewPIDNumber) > 4 Then
MsgBox "Bad Data Maaaaan...." & Chr(13) & Chr(13) & "The record = " & varPIDNumber
Exit Function
End If
Do Until Len(NewPIDNumber) = 4
NewPIDNumber = "0" & NewPIDNumber
Loop
End Function
Data Result
012a 0012
12a 0012
12 0012
85 0085
85adfe 0085
1002a 1002
1002 1002