I am trying to write a Do Loop that enters into a long string and returns the place of the space before an email address and the place of the space after. Using InStr() I have been able to locate the end of the email address. Now I need to locate the beginning to then use Mid() to pull the address out. I see that InStrRev() should start at the end of a string and then search, but looking at actual manuals it appears it just gives the second instance of a character. For example:
My string is:
please shoot me an email. My E-Mail: fake#gmail.com If you cannot make it call me.
What I have done so far is returned the place of the # , which in this case if 42. Then I used InStr() to return the place of the first " " after the #. Which in this case is, 52. I wish to return the place of the first " " BEFORE the #. In this case it should be 37. My plan then is to use Mid(37, 15). Fifteen being the difference of 52 & 37. I have tried using InStrRev() to return 37 but cannot get it to work. Any suggestions? below is my code.
x = 2
Do
Cells(x, 11).Select
Cells(x, 11).Value = (InStrRev(Cells(x, 9), Cells(x, 2), " "))
x = x + 1
On Error Resume Next
Loop Until Cells(x, 2).Value = ""
Where (x,9) is the place of the # and (x, 2) is the string.
or maybe if all you need is the email address:
Function GetEmail(longstr As String) As String
GetEmail = Filter(Split(longstr, " "), "#")(0)
End Function
Generally, looping should be avoided in Excel as it is slow, the below will do what your code does without the loop:
Columns(12).Cells(1).Resize(Columns(11).Cells(2).End(xlDown).Row - 1, 1).Offset(1).Value = _
Application.Transpose(Filter(Split(Join(Application.Transpose(Columns(11).Value), " "), " "), "#"))
How about:
MyArray = Split(Mystring," ")
For i=0 To Ubound(MyArray)
If Instr(MyArray(i)),"#")>0 Then
''Email
End If
Next
' Find the # symbol
Dim atPosition As Integer
atPosition = InStr(cellValue, "#")
' check if found here
' Find the space after the #
Dim secondSpacePosition As Integer
secondSpacePosition = InStr(atPosition, cellValue, " ")
' check if found here
' Find the space before the #
Dim firstSpacePosition As Integer
firstSpacePosition = InstrRev(cellValue, " ", atPosition) ' beware, the arguments differ a little
' check if found here
Dim email As String
email = Mid(cellvalue, firstSpacePosition + 1, secondSpacePosition - firstSpacePosition - 1)
Related
I have a mathematical problem: these five strings are IDs for the same object. Due to these differences, objects appear multiple times in my Access table/query. Although there are a lot of these mutations, but I take this as an example.
76 K 6-18
76 K 6-18(2)
0076 K 0006/ 2018
0076 K 0006/2018
76 K 6/18
How would the VBA-code have to look like to recognize that these numbers stand for the same thing , so a general formatting with "RegEx()" or "format()" or "replace()"...but they must not only refer to this example but to the kind.
The common factor of these and all other mutations is always the following:
1) includes "-", no zeros left of "-", just 18 an not 2018 (year) at the end.
2) is like the first but with (2) (which can be dropped).
3) includes "/", zeros left of "/", and 2018 as year at the end.
4) is like third, but without space after "/".
5) is like the first one, but with a "/" instead of "-".
Character is always one single "K"! I suppose the best way would be to convert all 5 strings to 76 K 6 18 or in ohter cases for example to 1 K 21 20 or 123 K 117 20 . Is this possible with one elegant code or formula? Thanks
Here is a fun alternative using a rather complex but intuitive regular expression:
^0*(\d+) (K) 0*(\d+)[-\/] ?\d{0,2}(\d\d)(?:\(\d+\))?$
See an online demo
^ - Start line anchor.
0* - 0+ zeros to catch any possible leading zeros.
(\d+) - A 1st capture group of 1+ digits ranging 0-9.
- A space character.
(K) - 2nd Capture group capturing the literal "K".
- A space character.
(\d+) - A 3rd capture group of 1+ digits ranging 0-9.
[-\/] - Character class of either a hyphen or forward slash.
? - An optional space character.
\d{0,2} - 0-2 digits ranging from 0-9.
(\d\d) - A 4th capture group holding exactly two digits.
(?:\(\d+\))? - An optional non-capture group holding 1+ digits inside literal paranthesis.
$ - End line anchor.
Now just replace the whole string by the 4 capture groups with spaces in between.
Let's test this in VBA:
'A code-block to call the function.
Sub Test()
Dim arr As Variant: arr = Array("76 K 6-18", "76 K 6-18(2)", "0076 K 0006/ 2018", "0076 K 0006/2018", "76 K 6/18")
For x = LBound(arr) To UBound(arr)
Debug.Print Transform(CStr(arr(x)))
Next
End Sub
'The function that transform the input.
Function Transform(StrIn As String) As String
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "^0*(\d+) (K) 0*(\d+)[-\/] ?\d{0,2}(\d\d)(?:\(\d+\))?$"
Transform = .Replace(StrIn, "$1 $2 $3 $4")
End With
End Function
All the elements from the initial array will Debug.Print "76 K 6 18".
Hope it helps, happy coding!
EDIT: If your goal is just to check if your string compiles against the pattern, the pattern itself can be shortened a little and you can return a boolean instead:
'A code-block to call the function.
Sub Test()
Dim arr As Variant: arr = Array("76 K 6-18", "76 K 6-18(2)", "0076 K 0006/ 2018", "0076 K 0006/2018", "76 K 6/18")
For x = LBound(arr) To UBound(arr)
Debug.Print Transform(CStr(arr(x)))
Next
End Sub
'The function that checks the input.
Function Transform(StrIn As String) As Boolean
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "^0*\d+ K 0*\d+[-\/] ?\d{2,4}(?:\(\d+\))?$"
Transform = .Test(StrIn)
End With
End Function
As #Vincent has suggested, look at using a custom function to convert all of the different data to be consistent. Based on what you have described, the following seems to work:
Function fConvertFormula(strData As String) As String
On Error GoTo E_Handle
Dim astrData() As String
strData = Replace(strData, "/", " ")
strData = Replace(strData, "-", " ")
strData = Replace(strData, " ", " ")
astrData = Split(strData, " ")
If UBound(astrData) = 3 Then
astrData(0) = CLng(astrData(0))
astrData(2) = CLng(astrData(2))
If InStr(astrData(3), "(") > 0 Then
astrData(3) = Left(astrData(3), InStr(astrData(3), "(") - 1)
End If
If Len(astrData(3)) = 4 Then
astrData(3) = Right(astrData(3), 2)
End If
fConvertFormula = Join(astrData, " ")
End If
fExit:
On Error Resume Next
Exit Function
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "fConvertFormula", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume fExit
End Function
It starts by replacing "field" delimiters with spaces, and then does a replace of double spaces. It then removes any leading zeroes from the first and third elements, if there is a bracket in the last element then delete that part, and finally converts to a 2 digit value before joining it all back up.
You may have other cases that you need to deal with, so I would suggest creating a query with the original data and the data converted by this function, and seeing what it throws out.
This function unifies the given string by the rules you defined in your question:
Public Function UnifyValue(ByVal inputValue As String) As String
'// Remove all from "(" on.
inputValue = Split(inputValue, "(")(0)
'// Replace / by blank
inputValue = Replace(inputValue, "/", " ")
'// Replace - by blank
inputValue = Replace(inputValue, "-", " ")
'// Replace double blanks by one blank
inputValue = Replace(inputValue, " ", " ")
'// Split by blank
Dim splittedInputValue() As String
splittedInputValue = Split(inputValue, " ")
'// Create the resulting string
UnifyValue = CLng(splittedInputValue(0)) & _
" " & splittedInputValue(1) & _
" " & CLng(splittedInputValue(2)) & _
" " & Right(CLng(splittedInputValue(3)), 2)
End Function
It always returns 76 K 6 18 regarding to your sample values.
I am trying to replace not each space in a single string with line break. String is taken from specific cell, and looks like:
Now, Im trying to replace each space after abbreviation to line break. The abbreviation can be any, so the best way for precaching which space I intend to replace is like: each space after number and before a letter?
The output I want to get is like:
Below is my code, but it will change every space to line break in cell.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Exitsub
If Not Intersect(Target, .Columns(6)) Is Nothing Then
Application.EnableEvents = False
Target.Value = Replace(Target, " ", Chr(10))
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
You can try
Target.Value = Replace(Target, "kg ", "kg" & Chr(10))
If you can have other abbreviations like "g" or "t", do something similar for them (maybe in a Sub), just be cautious with the order (replace first "kg", then "g")
Update: If you don't know in advance the possible abbreviations, one attempt is to use regular expressions. I'm not really good with them, but the following routine seems to do:
Function replaceAbbr(s As String) As String
Dim regex As New RegExp
regex.Global = True
regex.Pattern = "([a-z]+) "
replaceAbbr = regex.Replace(s, "$1" & Chr(10))
End Function
The below will replace every 2nd space with a carriage return. For reason unknown to me The worksheet function Replace will work as intended, but the VBA Replace doesnt
This will loop through every character in the defined area, you can change this to whatever you want.
The if statement is broken down as such
(SpaceCount Mod 2) = 0 this part is what enable it to get every 2nd character.
As a side note (SpaceCount Mod 3) = 0 will get the 3rd character and (SpaceCount Mod 2) = 1 will do the first character then every other character
Cells(1, 1).Characters(CountChr, 1).Text = " " is to make sure we are replacing a space, if the users enters something funny that looks like a space but isn't, that's on them
I believe something like this will work as intended for you
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Exitsub
Application.EnableEvents = False
For CountChr = 1 To Len(Target.Value)
If Target.Characters(CountChr, 1).Text = " " Then
Dim SpaceCount As Integer
SpaceCount = SpaceCount + 1
If (SpaceCount Mod 2) = 0 Then
Target.Value = WorksheetFunction.Replace(Target.Value, CountChr, 1, Chr(10))
End If
End If
Next CountChr
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Identify arbitrary abbreviation first
"abbreviations aren't determined ..."
Knowing the varying abbreviation which, however is the same within each string (here e.g. kg ) actually helps following the initial idea to look at the blanks first: but instead of replacing them all by vbLf or Chr(10), this approach
a) splits the string at this " " delimiter into a zero-based tmp array and immediately identifies the arbitrary abbreviation abbr as second token, i.e. tmp(1)
b) executes a negative filtering to get the numeric data and eventually
c) joins them together using the abbreviation which is known now for the given string.
So you could change your assignment to
'...
Target.Value = repl(Target) ' << calling help function repl()
Possible help function
Function repl(ByVal s As String) As String
'a) split into tokens and identify arbitrary abbreviation
Dim tmp, abbr As String
tmp = Split(s, " "): abbr = tmp(1)
'b) filter out abbreviation
tmp = Filter(tmp, abbr, Include:=False)
'c) return result string
repl = Join(tmp, " " & abbr & vbLf) & abbr
End Function
Edit // responding to FunThomas ' comment
ad a): If there might be missing spaces between number and abbreviation, the above approach could be modified as follows:
Function repl(ByVal s As String) As String
'a) split into tokens and identify arbitrary abbreviation
Dim tmp, abbr As String
tmp = Split(s, " "): abbr = tmp(1)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'b) renew splitting via found abbreviation (plus blank)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tmp = Split(s & " ", abbr & " ")
'c) return result string
repl = Join(tmp, abbr & vbLf): repl = Left(repl, Len(repl) - 1)
End Function
ad b): following OP citing e.g. "10 kg 20 kg 30,5kg 15kg 130,5 kg" (and as already remarked above) assumption is made that the abbreviation is the same for all values within one string, but can vary from item to item.
This site has been a veritable treasure chest of answers and ideas to many of my vba problems in the past, but i have not been able to find any concerning what i am sure is for many, if not most, here in this forum a simple task. I have to deal with a lot of xml report files that all have a header string and my problem is how to parse the string for the nuggest i require for my macro.
This is a sample string:
<Function IDREF="TST_RxRccsMatrix_Rx64" Start="2011-04-07T14:21:35.593000+02:00" Status="Success" Tags="SystemSerialNumber:41009" End="2011-04-07T14:29:16.625000+02:00">
I need to extract
- the report type: TST_RxRccsMatrix (length of this string is not constant)
- the start date-time stamp: 2011-04-07T14:21:35.593000+02:00 (length is constant)
- the serial number: 41009 (length is constant)
I have tried methods using Split and InStr and Find but none produce the desired results for all three extractions.
I truely appreciate any help on this!
The old fashion way is to use instr to find beginning. Then use instr to find ending. Then use mid to suck it out.
Begin = instr(1,xmlstring,"IDREF=") + Len("IDREF")
'look for first space after IDREF= in string
End = instr(Begin, xmlstring, " ")
Report = mid(xmlstring, begin, end - begin)
I didn't test it.
But I's split on space, then go through the array splitting on =. That will give you an array of 2 element arrays with value name in (0) and value in (1).
But xml has it's own query language and libraries to access stuff.
This is some code splitting a command line and then splitting 320x200 into 300 and 200.
CmdLine = Command()
A = Split(CmdLine, Chr(32), 2, 1)
B = Split(A(0), "x", 2, 1)
xmlstring = "<Function IDREF=""TST_RxRccsMatrix_Rx64"" Start=""2011-04-07T14:21:35.593000+02:00"" Status=""Success"" Tags=""SystemSerialNumber:41009"" End=""2011-04-07T14:29:16.625000+02:00"">"
Set regEx = New RegExp
regEx.Pattern = "IDREF=""([a-z0-9_]+)"""
regEx.IgnoreCase = True
regEx.Global = True
Set Matches = regEx.Execute(xmlstring)
If Matches.count <> 1 then msgbox "no match or too many"
For Each Match in Matches
Msgbox match.submatches(0)
Next
I answered your qustions. The other person deleted two easier ways of doing it.
Ask Oded to put back my explanation of this code. And to restore the MS tutorial on how to do it with XML DOM objects. I showed FOUR ways.
After some polishing:
Private Sub GetFileInfo()
Dim fso As New FileSystemObject, strText As Variant, i As Integer
Dim X(0 To 2) As String, Y(0 To 2) As String, B, E As Variant
'get header string from xml file
'FName (file name) was ascertained by a previous sub and is made public
Set strText = fso.OpenTextFile(FName, ForReading, False)
'header string is in second (i = 2) line of file
For i = 1 To 2: [A1] = strText.ReadLine: Next: strText.Close: Set fso = Nothing
'User Oded's search and extract routine
X(0) = "IDREF=": X(1) = "Start=": X(2) = "Tags="
For i = LBound(X(), 1) To UBound(X(), 1)
B = InStr(1, [A1], X(i)) + Len(X(i)) + 1 ' + 1 includes trailing " character
E = InStr(B, [A1], " ") - 1 ' - 1 includes leading " character
'required if a search string in X() is at the end of the header which ends with a ">"
If (InStr(B, [A1], " ") - 1) < 0 Then E = InStr(B, [A1], ">")
Y(i) = Mid([A1], B, E - B)
Next
[D1] = "Test = " & Y(0)
[D2] = "Tested on : " & Left(Y(1), 10) & " at " & Mid(Y(1), 12, 8)
[D2] = [D2] & " - " & Y(2)
End Sub
I'm trying to prepare a spreadsheet for a report in excel vba. Unforturnately there are some wierd characters here that need to be replaced. Easy enough, except for this chracter:
¦
I can't seem to be able to paste that character into the editor into a string replace function. When I try, the output is _. I then thought to refer to it by it's Chr code. A quick look up said it was Chr(166). http://www.gtwiki.org/mwiki/?title=VB_Chr_Values
Replace(s, "â€" + Chr(166), "...")
But this is not that character at all (at least on Mac excel). I tried:
For i = 1 To 255
Debug.Print Chr(i)
Next i
And I didn't see this character anywhere. Does anyone know how I can reference this character in vba code in order to replace it?
Not sure if regexp is available for vba-mac, but you could simplify your existing code greatly as below.
Uses a sample Strin
Dim strIn As String
strIn = "1â€1â€x123"
Do While InStr(strIn, "â€") > 0
Mid$(strIn, InStr(strIn, "â€"), 3) = "..."
Loop
Click on a cell containing your miscreant character and run this small macro:
Sub WhatIsIt()
Dim s As String, mesage As String
Dim L As Long
s = ActiveCell.Text
L = Len(s)
For i = 1 To L
ch = Mid(s, i, 1)
cd = Asc(ch)
mesage = mesage & ch & " " & cd & vbCrLf
Next i
MsgBox mesage
End Sub
It should reveal the characters in the cell and their codes.
It's dirty, but here's the workaround that I used to solve this problem. I knew that my issue character was always after "â€", so the idea was to replace the character that came after those 2. I don't really know how to replace a character at a position in a string, so my idea was to covert the string to an array of characters and replace the array at those specific indexes. Here's what it looks like:
Do While InStr(s, "â€") > 1
num2 = InStr(s, "â€")
arr = stringToArray(s)
arr(num2 - 1) = "<~>"
arr(num2) = "<~>"
arr(num2 + 1) = "<~>"
s = Replace(arrayToString(arr), "<~><~><~>", "...")
Loop
...
Function stringToArray(ByVal my_string As String) As Variant
Dim buff() As String
ReDim buff(Len(my_string) - 1)
For i = 1 To Len(my_string)
buff(i - 1) = Mid$(my_string, i, 1)
Next
stringToArray = buff
End Function
Function arrayToString(ByVal arr As Variant) As String
Dim s As String
For Each j In arr
s = s & j
Next j
arrayToString = s
End Function
In practice, what I replaced those indexes with is something that had to be unique but recognizable. Then i can replace my unique characters with whatever I want. There are sure to be edge cases, but for now it gets the job done. stringToArray function pulled from: Split string into array of characters?
I have excel cells which contain entries like this:
name/A/date
name/B/date
name/C/date
Cell content is displayed on multiple lines in the same cell. I would like to make only "name" bold for all entries. I recorded a macro and I think the solution must be something like this:
ActiveCell.FormulaR1C1 = "name/A/date" & Chr(10) & "name/B/date" & Chr(10) & "name/C/date"
With ActiveCell.Characters(Start:=25, Length:=4).Font
.FontStyle = "Bold"
End With
What I don't know is how to get the start value and the length of each entry. Anyone got an idea?
Have it now:
lngPos = InStr(ActiveCell.Value, "/")
With ActiveCell.Characters(Start:=1, Length:=lngPos - 1).Font
.FontStyle = "Bold"
End With
Inspired by various research in the last few days:
Dim totalVals, startPos(), endPos(), i, j, strLen As Long
Dim currLine As String
' Split the cell value (a string) in lines of text
splitVals = Split(ActiveCell.Value, Chr(10))
' This is how many lines you have
totalVals = UBound(splitVals)
' For each line, you'll have a character where you want the string to start being BOLD
ReDim startPos(0 To totalVals)
' And one character where you'll want it to stop
ReDim endPos(0 To totalVals)
' The value of the current line (before we loop on ActiveCell.Value) is empty
currLine = ""
For i = 0 To totalVals ' For each line...
' Length of the string currently treated by our code : 0 if no treatment yet...
strLen = Len(currLine)
' Here we parse and rewrite the current ActiveCell.Value, line by line, in a string
currLine = currLine & IIf(currLine = "", "", Chr(10)) & splitVals(i)
' At each step (= each line), we define the start position of the bold part
' Here, it is the 1st character of the new line, i.e. strLen + 1
startPos(i) = strLen + 1
' At each step (= each line), we define the end position of the bold part
' Here, it is just before the 1st "/" in the current line (hence we start from strLen)
endPos(i) = InStr(IIf(strLen = 0, 1, strLen), currLine, "/")
Next i
' Then we use the calculated positions to get the characters in bold
For j = 0 To UBound(startPos)
ActiveCell.Characters(startPos(j), endPos(j) - startPos(j)).Font.FontStyle = "Bold"
Next j
It might be a bit overdone, butI have tested it and it works like a charm. Hope this helps!
The answers above are perfectly fine. Since its related I wanted to include a similar routine I wrote to solve a formatting thing in my wife's macros.
in her situation we were consolidating string and wrote the concatenation into a single cell separated by a vbCrLf (Chr(10)) in her final output it would look something like this
Category number 1:
Category # 2:
Category 3:
The length of each category was different, and the # of categories may vary from 1 cell to the next. The pasted subroutine worked great
Sub BoldCategory()
RowCount = ActiveSheet.UsedRange.Rows.Count
Set MyRange = ActiveSheet.Range(Cells(2, 1), Cells(RowCount, 1))
For Each Cell In MyRange
i = 1
LineBreak = 1
Do While LineBreak <> 0
EndBoldPoint = InStr(i, Cell.Value, ":") + 1
BoldLength = EndBoldPoint - i
Cell.Characters(Start:=i, Length:=BoldLength).Font.FontStyle = "Bold"
LineBreak = InStr(i, Cell.Value, Chr(10))
i = LineBreak + 1
Loop
Next Cell
End Sub
So the ":" was the character I was keying in on to get the end point. the Chr(10) told me when 1 line ended and the next line began. When the last line was reached instr returned 0 therefore the while loop exits.