this script is going to extract each text between () from whole string. Now i would prepare it as a function because many string will be taking under that then i would like to add each extracted words inside table/or list. Each of extracted texts between () should be without special characters which sometimes could occur inside text and i would like to cut them of the string (i would like only to stay A-Z a-z 0-9 how could i do it all?
Sub Main()
Dim s$
s = "hsus(irt)bla dsd (got)(rifk)"
Debug.Print extract_value(s)
End Sub
Public Function extract_value$(s$)
Dim returnS$
Dim v
v = Split(s, Chr(40))
For Each Item In v
If InStr(Item, Chr(41)) Then
returnS = returnS & Chr(32) & Split(Item, ")")(0)
End If
Next
extract_value = Trim$(returnS)
End Function
When parsing you can use a helper function to check for just letters and numbers using the ASCII encoding.
Function validChr(chr As String) as Boolean
Dim ascCode As Integer
ascCode = Asc(chr)
If ascCode >= 65 And ascCode <= 90 Then 'Uppercase
validChr = True
ElseIf ascCode >= 97 And ascCode <= 122 Then 'Lowercase
validChr = True
ElseIf ascCode >= 48 And ascCode <= 57 Then 'Numbers
validChr = True
Else
validChr = False
End Function
You can also look at using RegEx.
This two stage `Regexp`
Converts hsus(ir%$%^t)bla dsd (g°ot)(rifk) to ir%$%^t g°ot rifk
In a single shot ir%$%^t g°ot rifkto irt got rifk
test sub
Sub Main()
Dim strTest As String
strTest = "hsus(ir%$%^t)bla dsd (g°ot)(rifk)"
MsgBox GrabIt(strTest)
End Sub
main sub
Function GrabIt(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.*?)\)"
.Global = True
If .test(strIn) Then
Set objRegMC = .Execute(strIn)
For Each objRegM In objRegMC
GrabIt = GrabIt & Chr(32) & objRegM.submatches(0)
Next
End If
.Pattern = "[^\w|\s]+"
GrabIt = .Replace(GrabIt, vbNullString)
End With
End Function
Related
I want to remove blank lines in a string as follows:
"First section
Second section
Third section"
I display a rolling index on every content slide so as you click through the slides, the index highlights the section you are in. I don't want to display subsections, so I tried to replace section names starting with "-" with "", but that means I have blank lines. So now I want to remove the blank lines.
I tried:
IIF statements but replacing with "" doesn't remove a blank line
Regular expressions, another link suggested the following pattern would work: #"^\s+$[\r\n]*" but the # throws up an error and it doesn't work in any case
I tried something like the below:
Dim RE As Object
Set RE = CreateObject("VBScript.RegExp")
With RE
.Multiline = True
.Global = True
resultString = .Replace(subjectString, "\s\n", string.empty)
MsgBox resultString
End With
Another potential solution I found on stackoverflow.
Dim xArr() as string
xArr = Split(TextBox1.Value, vbCrLf)
TextBox1.Value = ""
for i = 0 to Ubound(xArr)
If Trim(xArr(i)) <> "" Then
TextBox1.value = TextBox1.value & xArr(i) & vbCrLf
End If
Next
Looks like your RegEx code is actually intended for VB.Net rather than VBA, the code below replaces n blank lines with 1 in VBA.
Dim RE As Object: Set RE = CreateObject("VBScript.RegExp")
With RE
.MultiLine = True
.Global = True
.Pattern = "(\r\n)+"
resultString = .Replace(subjectString, vbCrLf)
MsgBox resultString
End With
Of course if you only ever have 2 blank lines you can simply:
resultString = replace$(subjectString, vbcrlf & vbcrlf, vbcrlf)
I know this is old but here's a regex Public Function i made to help. Theres probably a better way but this was simple for me and worked.
'=================================================================================='
Public Function RegExReplace(TextContent As String, SearchEx As String, Optional ReplaceEx As String = "", Optional _
EmptyLines As Boolean = False, Optional TrimLines As Boolean = True) As String
Dim regEx As Object, strOutput As String
Set regEx = CreateObject("vbscript.regexp")
With regEx: .Global = True: .IgnoreCase = False: .MultiLine = True: .Pattern = SearchEx: End With
TextContent = regEx.Replace(TextContent, ReplaceEx)
If EmptyLines = False Then TextContent = RegExReplace(TextContent, "\r\n\r\n", "", True, False)
If TrimLines = True Then TextContent = Trim(TextContent)
RegExReplace = TextContent: Set regEx = Nothing
End Function
'=================================================================================='
If for whatever reason you'd prefer to avoid using RegEx (working on a Mac where VBScript isn't available for example), here's a purely VB approach:
Sub Test()
Call TakeOutTheEmpties(ActiveWindow.Selection.ShapeRange(1))
End Sub
Sub TakeOutTheEmpties(oSh As Shape)
Dim oPara As TextRange
Dim x As Long
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
For x = oSh.TextFrame.TextRange.Paragraphs.Count To 1 Step -1
Set oPara = oSh.TextFrame.TextRange.Paragraphs(x)
If oPara.Text = vbCr Then
oPara.Delete
End If
Next
End If
End If
End Sub
I have more than one text with the word "123" inside Textabc
like a123b , c123erf and 123
but I just wanna locate the exact word "123"
Text_u1 = Mid(Textabc, InStr(Text, "123"))
I tried &123& but not working
Thanks
Option Explicit
Sub GetWord()
Dim Textabc As String, s As Variant, i As Variant, abc As String, sz As Long
Dim foundStart As Long, foundLen As Long
Textabc = "like a123b , c123erf and 123"
abc = "123"
s = Split(Textabc)
For i = 0 To UBound(s)
sz = sz + Len(s(i)) + 1
If Trim(s(i)) = abc Then
foundStart = sz - Len(s(i))
foundLen = Len(Textabc) - (sz - Len(s(i))) + 1
Debug.Print "Textabc length: " & Len(Textabc)
Debug.Print "foundStart: " & foundStart
Debug.Print "foundLen: " & foundLen
Debug.Print Mid(Textabc, foundStart, foundLen)
End If
Next
End Sub
Try one of these two, depending on what you want:
Public Sub TestMe()
Debug.Print InStr("a123b", "123")
Debug.Print Mid("a123b", InStr("a123b", "123"))
End Sub
You can try using Regular Expressions
Sub Test()
Dim regEx As Object
Dim str As String
Set regEx = CreateObject("vbscript.RegExp")
str = "a123b , c123erf and 123"
With regEx
.Global = True
.IgnoreCase = True
.Pattern = "\b(123)"
Debug.Print regEx.Execute(str)(0).FirstIndex + 1
End With
End Sub
This will return the position of the first match it finds that is equal to just 123 everything else will be ignored. If there are more then one match you will need to loop over the output of regEx.Execute(str) to get each position
I am trying to add slashes between characters in a string, e. g. hello -> h/e/l/l/o
I tried to use Replace(string, "", "/") but the String remained unchanged.
Try this:
Sub Main
dim initial_text as string
dim final_text as string
initial_text = "hello"
final_text = ""
Dim i As Integer
For i = 1 To len(initial_text)
if i = len(initial_text) then
final_text = final_text + Mid(initial_text,i,1)
else
final_text = final_text + Mid(initial_text,i,1) + "/"
end if
Next i
msgbox final_text
End Sub
EDIT
For study porpuse, I add another answer based on comments from (The next answer is a good answer too):
Dim s As String
s = "Hello"
#wqw
Debug.Print Left(Replace(StrConv(s, vbUnicode), Chr$(0), "/"), Len(s) * 2 - 1)
#Jeeped
Debug.Print Left(Join(Split(StrConv(s, vbUnicode), Chr$(0)), "/"), Len(s) * 2 - 1)
Here is an emulation of preg_replace function from PHP that I'm using which allows a simple regex to do the job. The look-ahead part gets rid of the last slash too.
Option Explicit
Private Sub Form_Load()
Dim s As String
s = "Hello"
Debug.Print preg_replace("(.)(?=.)", "$1/", s)
End Sub
Public Function preg_replace(sPattern As String, sReplace As String, sText As String) As String
Dim lIdx As Long
With CreateObject("VBScript.RegExp")
.Global = True
If Left$(sPattern, 1) = "/" Then
lIdx = InStrRev(sPattern, "/")
.Pattern = Mid$(sPattern, 2, lIdx - 2)
.IgnoreCase = (InStr(lIdx, sPattern, "i") > 0)
.MultiLine = (InStr(lIdx, sPattern, "m") > 0)
Else
.Pattern = sPattern
End If
preg_replace = .Replace(sText, sReplace)
End With
End Function
How to find the first instance of a "lower case character" in a cell using VBA in Excel?
I have tried using ASCII values but that didn't work.
Try the following small UDF:
Public Function Findlower(rin As Range) As Long
Dim v As String, CH As String, i As Long
Findlower = 0
v = rin.Text
L = Len(v)
For i = 1 To L
If Mid(v, i, 1) Like "[a-z]" Then
Findlower = i
Exit Function
End If
Next i
End Function
It will return the position of the first instance of any lower case letter in a string:
You can use a RegExp in a UDF to avoid looping through each character:
Function FirstLower(strIn As String) as String
Dim objRegex As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "[a-z]"
.ignorecase = False
If .test(strIn) Then
Set objRegM = .Execute(strIn)(0)
FirstLower = objRegM.firstindex + 1
Else
FirstLower = "no match"
End If
End With
End Function
I think you want to remove the first part in your string that is in lower case:
Public Function DeletFirstLowerPart(strTemp As String) As String
Dim strResult As String, i As Long, findLower As Boolean
strResult = ""
findLower = False
For i = 1 To Len(strTemp)
If (Mid(strTemp, i, 1) Like "[a-z]") Then
findLower = True
Else
If findLower = True Then
strResult = strResult & Mid(strTemp, i)
DeletFirstLowerPart = strResult
Exit Function
End If
strResult = strResult & Mid(strTemp, i, 1)
End If
Next i
DeletFirstLowerPart = strResult
End Function
DeletFirstLowerPart("ABCdefGHI") = "ABCGHI"
DeletFirstLowerPart("ABCdefGHIjkl") = "ABCGHIjkl"
Private Function DeleteLowerCasesLike(InputString As String) As String
Dim i As Integer
For i = 1 To Len(InputString)
If Mid(InputString, i, 1) Like "[a-z]" Then
InputString = Left(InputString, i - 1) & Mid(InputString, i + 1)
i = i - 1
End If
Next
DeleteLowerCasesLike = InputString
End Function
Another RegExp solution which needs to addig referance to Microsoft VBScript Regular Expressions 1.0 (In the VBA window, Tools->Referances menu)
Private Function DeleteLowerCasesRegExp(InputString As String)
Dim RE As New RegExp
With RE
.Global = True
.IgnoreCase = False
.Pattern = "[a-z]"
DeleteLowerCasesRegExp = .Replace(InputString, "")
End With
End Function
And another solution nor Like neither RegExp is used:
Private Function DeleteLowerCasesAsc(InputString As String) As String
Dim i As Integer
For i = 1 To Len(InputString)
If Mid(InputString, i, 1) = Empty Then Exit For
If Asc(Mid(InputString, i, 1)) >= 97 And Asc(Mid(InputString, i, 1)) <= 122 Then
InputString = Left(InputString, i - 1) & Mid(InputString, i + 1)
i = i - 1
End If
Next
DeleteLowerCasesAsc = InputString
End Function
Another solution in which replace function is used:
Private Function DeleteLowerCasesReplace(InputString As String) As String
Dim i As Integer
For i = 97 To 122
InputString = Replace(InputString, Chr(i), "")
Next
DeleteLowerCasesReplace = InputString
End Function
The code from Get the value between the brackets works well if the cell contains just one "(text)".
Unfortunately, in my rows there are many "Sample (sample1) (sample2)" format sentences and I need the last part.
Function GetParen(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.+?)\)"
If .Test(strIn) Then
Set objRegMC = .Execute(strIn)
GetParen = objRegMC(0).submatches(0)
Else
GetParen = "No match"
End If
End With
Set objRegex = Nothing
End Function
Could somebody help me to modify the code? Because if the cell contains "Text (text part1) (text part2)" The result what I get is "text part1" but I need the "text part2".
Thanks.
Why bother with regex ?? Consider the alternative:
Public Function GetParen(strIn As String) As String
Dim gather As Boolean, L As Long, i As Long
Dim CH As String
gather = False
L = Len(strIn)
For i = L To 1 Step -1
CH = Mid(strIn, i, 1)
If gather Then GetParen = CH & GetParen
If CH = ")" Then gather = True
If CH = "(" Then Exit For
Next i
GetParen = Mid(GetParen, 2)
End Function
EDIT#1:
Simpler:
Public Function GetParen2(strIn As String) As String
ary = Split(strIn, "(")
bry = Split(ary(UBound(ary)), ")")
GetParen2 = bry(0)
End Function
tiborjan:
I have a function that I wrote for just that reason. Here it is:
Function SubStr(s1 As String, sLeft As String, sL_Occ As Integer, sRight As String, sR_Occ As Integer) As String
'Cuts a piece of text from between two strings within another string
Dim LeftBound As Integer, RightBound As Integer, i As Integer
If sLeft = "Minimum" Then
LeftBound = 0
Else
For i = 1 To sL_Occ
LeftBound = InStr(LeftBound + 1, s1, sLeft, vbTextCompare)
Next i
End If
LeftBound = LeftBound + Len(sLeft) - 1 'measure from the right of the left bound
If sRight = "Maximum" Then
RightBound = Len(s1) + 1
Else
For i = 1 To sR_Occ
RightBound = InStr(RightBound + 1, s1, sRight, vbTextCompare)
Next i
End If
SubStr = Mid(s1, LeftBound + 1, RightBound - LeftBound - 1)
End Function
It has 5 parameters:
s1: the string that contains the text you want to parse
sLeft: the left-bound of the text you want to parse. Use "(" for your application.
sL_Occ: iteration number of sLeft. So if you wanted the second "(" that appears in s1, make this 2.
sRight: same as sLeft, but the right-bound.
sR_Occ: same as sL_Occ, but referring to the right-bound.
To make it easy: use this function code instead of yours. If you want to pull text from the second set of parentheses, use
s1 = "(P1) (P2) (P3) (P4)"
sLeft = "("
sL_Occ = 2
sRight = ")"
sR_Occ = 2
The return in the above would be "P2".
Hope that helps!
Matt, via ExcelArchitect.com
or how about simply
Function LastParam(ByVal str As String) As String
Dim arr() As String
arr = Split(str, "(")
LastParam = Split(arr(UBound(arr, 1)), ")")(0)
End Function
For completeness, you would only need minor changes to your code to make it work with your regex.
Set the Global flag to True, and return the last match from the match collection.
Function GetParen(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "\((.+?)\)"
If .Test(strIn) Then
Set objRegMC = .Execute(strIn)
GetParen = objRegMC(objRegMC.Count - 1).submatches(0)
Else
GetParen = "No match"
End If
End With
Set objRegex = Nothing
End Function
A minor tweak to my earlier Regexpwill extract the last match.
test
Sub Test()
MsgBox GetParen("(Sample (sample1) (sample2)")
End Sub
code
Function GetParen(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.+?)\)"
.Global = True
If .Test(strIn) Then
Set objRegMC = .Execute(strIn)
GetParen = objRegMC(objRegMC.Count - 1).submatches(0)
Else
GetParen = "No match"
End If
End With
Set objRegex = Nothing
End Function