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
Related
I have a Word doc with some numbers referred in the foot notes. and I am exporting these references as a csv file.
Sub FindNumber()
Dim exp, exp1 As RegExp
Set exp = New RegExp
exp.Pattern = "\b[A-Za-z]{3}[0-9]{7}\b"
exp.Global = True
Dim splits(1000) As String
Dim x As Long
Dim results As MatchCollection
Set results = exp.Execute(ActiveDocument.StoryRanges(wdFootnotesStory))
x = 1
For Each res In results
splits(x) = res
x = x + 1
Next res
Dim Filename As String, line As String
Dim i As Integer
Filename = "C:\VBA Export" & "\Numbers.csv"
Open Filename For Output As #2
Print #2, "Control Numbers"
For i = LBound(splits) To UBound(splits)
Print #2, splits(i)
Next i
Close #2
MsgBox "Numbers were exported to " & Filename, vbInformation
End Sub
The code above was working fine and just suddenly starting throwing error at 'splits(x) = res'
I have tried checking my regex and I can see that it works fine. If I change splits(x) to splits(6) or something similar it works like a charm .
Can someone please help ?
EDIT - changed code to write matches directly to Excel.
Sub Tester()
Dim oXl As Excel.Application 'add reference to MS Excel object library...
Dim oWb As Excel.Workbook, c As Excel.Range, i As Long, col As Collection
Set oXl = New Excel.Application
oXl.Visible = True
Set oWb = oXl.Workbooks.Add()
Set c = oWb.Worksheets(1).Range("A1")
ListMatchesInExcel ActiveDocument.StoryRanges(wdFootnotesStory), _
"\b[A-Za-z]{3}[0-9]{7}\b", _
"Id Numbers", c
Set c = c.Offset(0, 1)
ListMatchesInExcel ActiveDocument.StoryRanges(wdFootnotesStory), _
"\b[A-Za-z]{2}[0-9]{9}\b", _
"Other Numbers", c
Set c = c.Offset(0, 1)
'etc etc
End Sub
'Search through `SearchText` for text matching `patt` and export all
' matches to Excel with a header `HeaderText`, starting at range `c`
Sub ListMatchesInExcel(SearchText As String, patt As String, _
headerText As String, c As Excel.Range)
'add reference to MicroSoft VBscript regular expressions
Dim exp, exp1 As RegExp, col As New Collection
Dim results As MatchCollection, res As Match, i As Long
Set exp = New RegExp
exp.Pattern = patt
exp.Global = True
Set results = exp.Execute(SearchText)
'log to Immediate pane
Debug.Print (col.Count - 1) & " matche(s) for '" & patt & "'"
c.Value = headerText
i = 1
For Each res In results
c.Offset(i).Value = res
i = i + 1
Next res
c.EntireColumn.AutoFit
End Sub
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
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
I want to remove some words that aren't in a separate list from an excel list.
Someone gave me an example with Find/Replace, but i need the exact opposite, meaning that i want to keep the words in the list and remove the other. Also if a word is removed, I would have more than 1 space so i would need to remove multiple spaces.
Can anyone give me an example?
Thanks,
Sebastian
EDIT
Initial cell contents: word1 word2 word3 word4
Cell contents after script: word2 word4
My list contains: word2, word4, word7, ...
This works:
Sub words()
Dim whitelist() As Variant
Dim listToScreen As Variant
Dim screenedList As String
Dim itsInTheWhitelist As Boolean
Dim i As Long
Dim j As Long
' Words to keep
whitelist = Array("word2", "word4", "word7")
' Input old cell contents, split into array using space delimiter
listToScreen = Split(Range("A1").Value, " ")
screenedList = ""
For i = LBound(listToScreen) To UBound(listToScreen)
' Is the current word in the whitelist?
itsInTheWhitelist = False
For j = LBound(whitelist) To UBound(whitelist)
If listToScreen(i) = whitelist(j) Then
itsInTheWhitelist = True
Exit For
End If
Next j
If itsInTheWhitelist = True Then
' Add it to the screened list, with space delimiter if required
If Not screenedList = "" Then
screenedList = screenedList & " "
End If
screenedList = screenedList & listToScreen(i)
End If
Next i
'Output new cell contents
Range("A2").Value = screenedList
End Sub
Using a Scripting.Dictionary and a RegExp will cost two references, but will avoid a N*N loop:
' needs ref to Microsoft Scripting Runtime,
' Microsoft VBScript Regular Expressions 5.5
Option Explicit
Sub frsAttempt()
Dim sInp As String: sInp = "word1 word2 word3 word4"
Dim aInp As Variant: aInp = Split(sInp)
Dim sExp As String: sExp = "word2 word4"
Dim sLst As String: sLst = "word2, word4, word7"
Dim aLst As Variant: aLst = Split(sLst, ", ")
Dim dicGoodWords As New Dictionary
Dim nIdx
For nIdx = 0 To UBound(aLst)
dicGoodWords(aLst(nIdx)) = 0
Next
For nIdx = 0 To UBound(aInp)
If Not dicGoodWords.Exists(aInp(nIdx)) Then
aInp(nIdx) = ""
End If
Next
Dim sRes As String: sRes = Join(aInp)
Dim reCleanWS As New RegExp
reCleanWS.Global = True
reCleanWS.Pattern = "\s+"
sRes = Trim(reCleanWS.Replace(sRes, " "))
Debug.Print sExp
Debug.Print sRes
Debug.Print sRes = sExp
End Sub
Output:
word2 word4
word2 word4
True
The dictionary could be filled from a WorkSheet's column.