This has probably been asked a million times in different variations but I can't find an answer that fits.
I have a string that contains up to 4 MUT IDs ("MUT" followed by 5 numbers, eg MUT00761). If there is more than one ID, they are separated by a space. In some occasion, there will also be a * between two IDs (eg MUT00761 * MUT00684). The * is associated with the MUT ID on its left. I need to remove all those MUT IDs (and their *),if any.
EG, "MUT00111 MUT00222 * MUT00333 MUT00444 *" needs to become "MUT00111 MUT00333".
Worksheet Formula
=IFERROR(TRIM(SUBSTITUTE(A1,MID(A1,FIND("*",A1)-9,10),"")),A1)
VBA UDF
Function MUT(S as String) as String
On Error Resume Next
MUT = Trim(Replace(S, Mid(S, InStr(1, S, "*") - 9, 10), vbNullString))
If CBool(Err.Number) Then MUT = S
End Sub
1) get the position of 1st MUT with something instr(1,entireText, "MUT"[, …])
2) cut out MUT plus x characters or until the next "," with
3) do again until no MUT is found
Use the Microsoft VBScript Regular Expresions 5.5 library to replace instances of 'MUT *' with vbNullString.
OR
If you don;t grok Regex a simple function like
Public Function StripStarredIds(ByVal IdString As String) As String
Do While InStr(IdString, "*")
IdString = Replace(IdString, Mid$(IdString, InStr(IdString, "*") - 10, 10), vbNullString)
Loop
StripStarredIds = IdString
End Function
I would use a custom function to do this. It may be a bit clunky but this should work:
Function StripText(ByVal fullText As String) As String
newText = ""
lastIndex = 1
curIndex = InStr(1, fullText, " *")
If curIndex = 0 Then '// if no instances of " *" are found then just copy the full text
newText = fullText
Else
Do While (curIndex > 0) '// do until no instances of " *" are found
newText = newText & Mid(fullText, lastIndex, curIndex - lastIndex - 9)
lastIndex = curIndex + 2
curIndex = InStr(lastIndex + 1, fullText, " *")
Loop
End If
StripText = newText
End Function
you could use Split() function like this:
Function GiveItAName(s As String) As String
Dim res As String
Dim v As Variant, w As Variant
Dim i As Long, j As Long
v = Split(s, " *")
For j = 0 To UBound(v) - 1
w = Split(v(j), " ")
For i = 0 To UBound(w) - 1
res = res & w(i) & " "
Next
Next
GiveItAName = WorksheetFunction.Trim(res & v(j))
End Function
Related
I have a access table and i am writing a vba code to remove non-ascii characters from the table, i have tried using below two functions
Public Function removeall(stringData As String) As String
Dim letter As Integer
Dim final As String
Dim i As Integer
For i = 1 To Len(stringData) 'loop thru each char in stringData
letter = Asc(Mid(stringData, i, 1)) 'find the char and assign asc value
Select Case letter 'Determine what type of char it is
Case Is < 91 And letter > 64 'is an upper case char
final = final & Chr(letter)
Case Is < 123 And letter > 96 'is an lower case char
final = final & Chr(letter)
Case Is = 32 'is a space
final = final & Chr(letter)
End Select
Next i
removeall = final
End Function
And also tried using below function
Public Function Clean(InString As String) As String
'-- Returns only printable characters from InString
Dim x As Integer
For x = 1 To Len(InString)
If Asc(Mid(InString, x, 1)) > 31 And Asc(Mid(InString, x, 1)) < 127 Then
Clean = Clean & Mid(InString, x, 1)
End If
Next x
End Function
But the problem is : In removeall function it removes everything including # and space characters.. And In Clean function also removes special characters as well.
I need a correct function which retains key board characters and removes all other characters
Examples of strings in tables are :
1) "ATTACHMENT FEEDING TUBE FITS 5-18 ºFR# "
2) "CATHETER FOLEY 3WAY SILI ELAST 20FR 30ML LATEXº"
Any help would be greatly appreciated
Output should be like
1) "ATTACHMENT FEEDING TUBE FITS 5-18 FR"
2) "CATHETER FOLEY 3WAY SILI ELAST 20FR 30ML LATEX"
One approach would be to use a whitelist of accepted characters. e.g.
' You can set up your domain specific list:
Const Whitelist = "1234567890" & _
"qwertyuiopasdfghjklzxcvbnm" & _
"QWERTYUIOPASDFGHJKLZXCVBNM" & _
" `~!##$%^&*()_-=+[]{};:""'|\<>?/ –"
Public Sub test()
Debug.Print Clean("ATTACHMENT FEEDING TUBE FITS 5-18 ºFR#")
Debug.Print Clean("CATHETER FOLEY 3WAY SILI ELAST 20FR 30ML LATEXº")
End Sub
Public Function isAllowed(char As String) As Boolean
isAllowed = InStr(1, Whitelist, char, vbBinaryCompare) > 0
End Function
Public Function Clean(dirty As String) As String
'-- Returns only printable characters from dirty
Dim x As Integer
Dim c As String
For x = 1 To Len(dirty)
c = Mid(dirty, x, 1)
If isAllowed(c) Then
Clean = Clean & c
End If
Next x
End Function
Alternate approach that preserves ALL ASCII characters, without working with a whitelist, in a single function:
Public Function RemoveNonASCII(str As String) As String
Dim i As Integer
For i = 1 To Len(str)
If AscW(Mid(str, i, 1)) < 127 Then 'It's an ASCII character
RemoveNonASCII = RemoveNonASCII & Mid(str, i, 1) 'Append it
End If
Next i
End Function
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))
I built a macro that saves workbooks based on a list of names.
I'm getting a saveAs error because some of the new list items, have / which are not allowed in a file name.
I need some help in writing a code that will do this: note, that the list of teams, names, leagues and cups changes every row.
list item: team/ league
what I want: league
list item: team / league / cup
What I want: league-cup
List item; team / league / cup / score
what I want: league-cup-score
I have it working for the first scenario where there is only one / but can't figure out for rest.
InStr(Value, "/") > 0 Then
filename = Right(Value, (Len(Value) - InStr(Value, "/")))
Else
filename = Value
End If
is what I got so far.
Thanks
You could split, trim, and join:
Function MakeFileName(s As String) As String
Dim v As Variant, w As Variant
Dim i As Long, n As Long
v = Split(s, "/")
n = UBound(v)
ReDim w(1 To n)
For i = 1 To n
w(i) = Trim(v(i))
Next i
MakeFileName = Join(w, "-")
End Function
For example:
Sub test()
Debug.Print MakeFileName("team/ league")
Debug.Print MakeFileName("team / league / cup")
Debug.Print MakeFileName("team / league / cup / score")
End Sub
Output:
league
league-cup
league-cup-score
Yet another solution, this time using InStr. Edited to handle where no league is present.
Sub Example()
Dim str1 As String: str1 = "list item: team/ league"
Dim str2 As String: str2 = "list item: team / league / cup "
Dim str3 As String: str3 = "List item; team / league / cup / score"
Debug.Print getTeamText(str1)
Debug.Print getTeamText(str2)
Debug.Print getTeamText(str3)
End Sub
Function getTeamText(ByVal StringIn As String) As String
Dim strPos As Long
Dim lookFor As String: lookFor = "league"
strPos = InStr(1, LCase(StringIn), lookFor)
If strPos > 0 Then
getTeamText = Replace(Replace(Mid(StringIn, strPos, (Len(StringIn) - strPos) + 1), " ", ""), "/", "-")
Else
getTeamText = "Could not find match"
End If
End Function
Output should be as expected.
Using the code you already have, you can use the VBA replace function to replace "/" with "-"
filename = Replace(filename, "/", "-")
You need to use REPLACE
https://www.techonthenet.com/excel/formulas/replace_vba.php
example:
Dim oldString as String
Dim newString as String
newString=Replace(oldString,"/","_")
you could use
filename = Join(Split(Replace(Replace(Value, " ", ""), "team/", ""), "/"), "-")
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 am trying to make a program that changes letters in a string and i keep running into the obvious issue of if it changes a value, say it changes A to M, when it gets to M it will then change that M to something else, so when i run the code to change it all back it converts it as if the letter was originally an M not an A.
Any ideas how to make it so the code doesnt change letters its already changed?
as for code ive just got about 40 lines of this (im sure theres a cleaner way to do it but im new to vba and when i tried select case it would only change one letter and not go through all of them)
Text1.value = Replace(Text1.value, "M", "E")
Try this:
Dim strToChange As String
strToChange = "This is my string that will be changed"
Dim arrReplacements As Variant
arrReplacements = Array(Array("a", "m"), _
Array("m", "z"), _
Array("s", "r"), _
Array("r", "q"), _
Array("t", "a"))
Dim strOutput As String
strOutput = ""
Dim i As Integer
Dim strCurrentLetter As String
For i = 1 To Len(strToChange)
strCurrentLetter = Mid(strToChange, i, 1)
Dim arrReplacement As Variant
For Each arrReplacement In arrReplacements
If (strCurrentLetter = arrReplacement(0)) Then
strCurrentLetter = Replace(strCurrentLetter, arrReplacement(0), arrReplacement(1))
Exit For
End If
Next
strOutput = strOutput & strCurrentLetter
Next
Here is the output:
Thir ir zy raqing ahma will be chmnged
Loop through it using the MID function. Something like:
MyVal = text1.value
For X = 1 to Len(MyVal)
MyVal = Replace(Mid(MyVal, X, 1), "M", "E")
X = X + 1
Next X
EDIT: OK upon further light, I'm gonna make one change. Store the pairs in a table. Then you can use DLookup to do the translation, using the same concept:
MyVal = text1.value
For X = 1 to Len(MyVal)
NewVal = DLookup("tblConvert", "fldNewVal", "fldOldVal = '" & Mid(MyVal, X, 1) & "")
MyVal = Replace(Mid(MyVal, X, 1), Mid(MyVal, X, 1), NewVal)
X = X + 1
Next X
Here's another way that uses less loops
Public Function Obfuscate(sInput As String) As String
Dim vaBefore As Variant
Dim vaAfter As Variant
Dim i As Long
Dim sReturn As String
sReturn = sInput
vaBefore = Split("a,m,s,r,t", ",")
vaAfter = Split("m,z,r,q,a", ",")
For i = LBound(vaBefore) To UBound(vaBefore)
sReturn = Replace$(sReturn, vaBefore(i), "&" & Asc(vaAfter(i)))
Next i
For i = LBound(vaAfter) To UBound(vaAfter)
sReturn = Replace$(sReturn, "&" & Asc(vaAfter(i)), vaAfter(i))
Next i
Obfuscate = sReturn
End Function
It turns every letter into an ampersand + the replacement letters ascii code. Then it turns every ascii code in the replacement letter.
It took about 5 milliseconds vs 20 milliseconds for the nested loops.