I have a string called str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1 I need to reverse the string so it looks like this str = "12345-1, 12345-2, 12345-3, 12345-4, 12345-5"
I have tried the strReverse method, and it almost did what I wanted...
Sub rev()
Dim str As String
str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1"
str = StrReverse(Trim(str))
'turns out to be str = "1-54321 ,2-54321 ,3-54321 ,4-54321 ,5-54321"
End Sub
but it ended up reversing the whole string, should have guessed that. So I'm wondering should I use a regex expression to parse the string and remove the "12345-" and then reverse it and add it back in? I'm not too sure if that would be the best method for my problem. Does anyone know a solution to my problem or could point me in the right direction? Thanks
Use Split then loop backwards through the array:
Sub rev()
Dim str As String
str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1"
Dim strArr() As String
strArr = Split(str, ",")
str = ""
Dim i As Long
For i = UBound(strArr) To LBound(strArr) Step -1
str = str & ", " & Trim(strArr(i))
Next i
str = Mid(str, 3)
Debug.Print str
End Sub
I would do it like this:
Sub TestMe()
Dim str As String
str = "12345-5, 12345-4, 12345-3, 12345-2, 12345-1"
str = StrReverse(str)
Dim myArr As Variant
myArr = Split(str, ",")
Dim newString As String
Dim myA As Variant
For Each myA In myArr
newString = newString & StrReverse(myA) & ","
Next myA
newString = Trim(Left(newString, Len(newString) - 1))
Debug.Print newString
End Sub
Getting this:
12345-1, 12345-2, 12345-3, 12345-4,12345-5
In general, this is quite popular Algorithmic problem, which used to be asked by Google for Junior Developers. Sounding like this - Efficiently reverse the order of the words (not characters) in an array of characters
Related
I have a problem extracting words in MS Excel. I have multiple sentences in HTML format in a row and want to extract all of the words that are delimited by <b>....</b>
Example:
<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b>
I want to extract the words: "buat", "1", "2", "cendol"
Can you help me to solve my problem? Any code in Excel/VBA is appreciated.
This can be done with the worksheet function FILTERXML if you have Excel 2013+
First you need to change your string into a "well-formed" XML by enclosing it in an external tag, and closing off the unmatched <br> tag:
"<t>" & $A$1 & "</br></t>"
Then it's merely a matter of using an Xpath that will return all of the wanted tags:
FILTERXML("<t>" & $A$1 & "</br></t>","//b")
Wrapping that in an INDEX function allows you to extract the substrings one at a time:
Full Formula entered in A3 and filled down
=IFERROR(INDEX(FILTERXML("<t>" & $A$1 & "</br></t>","//b"),ROWS($1:1)),"")
There's a very easy way to do this by using an HTMLDocument object:
In your VB Editor, go to Tools>References and select the Microsoft HTML Object Library.
Then you can use the following code:
Sub extract()
Dim doc As New HTMLDocument 'Declare and create an object of type HTMLDocument
Dim item As HTMLObjectElement 'Declare an object of type HTMLObjectElement. We will use this to loop through a collection of HTML elements
doc.body.innerHTML = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> " 'Assign your HTML code as a string in doc body
For Each item In doc.getElementsByTagName("b") 'Loop through all the <b></b> elements in doc
Debug.Print item.innerText 'print the text contained in <b></b> element. This will show up in your immediate window
Next item
End Sub
Try this
Sub Test()
Dim objReg As Object
Dim objMatches As Object
Dim match As Object
Dim s As String
Dim i As Integer
s = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> "
Set objReg = CreateObject("VBScript.RegExp")
With objReg
.IgnoreCase = False
.Global = True
.Pattern = "<b>(.*?)<\/b>"
Set objMatches = .Execute(s)
End With
For Each match In objMatches
For i = 0 To match.Submatches.Count - 1
Debug.Print Trim(match.Submatches.item(i))
Next i
Next match
Set objReg = Nothing
End Sub
Alternative using XML DomDocument
Analyzing a HTML string it seems evident to use document object structures as in a HTMLDocument or in ►XML. That's why I demonstrate a further approach for the sake of completeness and in addition to #StavrosJon 's valid solution (which uses the more lenient HTMLDocument not needing to be well formed as XML is):
Example call
Sub ExtractViaXML()
Dim html$, myArray()
html = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> "
myArray = getTokens(html, "b") ' assign findings to array via function getTokens()
Debug.Print UBound(myArray) + 1 & " token(s) found: " & Join(myArray, ", ") ' display results
End Sub
Main function getTokens()
Function getTokens(ByVal html$, Optional myTag$ = "b") As Variant()
' Purpose: isolate "<b>"-Tags (default value) out of html string and return found tokens as variant array
' Note: creates temporary XML DOMDocument (late bound MSXML2 reference)
Dim XmlString$
XmlString = wellformed("<?xml version=""1.0"" encoding=""utf-8""?><tokens>" & html & "</tokens>")
With CreateObject("MSXML2.DOMDocument.6.0")
.ValidateOnParse = True: .Async = False
If .LoadXML(XmlString) Then ' load xml string
Dim myNodeList As Object
Set myNodeList = .DocumentElement.SelectNodes(myTag) ' set node list to memory
Dim i&, ii&, arr()
ii = myNodeList.Length - 1 ' calculate upper boundary of zero-based array
If ii > -1 Then ReDim arr(ii) ' (re)dimension variant array arr()
For i = 0 To ii ' loop through node list
arr(i) = myNodeList.item(i).Text ' assign each found text content to array
Next i
If ii = -1 Then arr = Array("**Nothing found**") ' provide for zero findings
getTokens = arr ' return 0-based 1-dim array with found tokens
Else: ShowParseError (.ParseError) ' optional: display possible error message
End If
End With
End Function
Helper functions
XML requires a well formed node structure with opening and closing tags or, whereas HTML is more lenient towards e.g. single line breaks(<br>). Therefore I added a simple function wellformed() to cure such an issue preventing successful loading. Furthermore I demonstrate using an optional procedure ShowParseError to localize (other) possible loading Errors which you can use as supplement to any .load or .loadXML function.
Function wellformed$(ByVal s$)
' Purpose: force a wellformed version of line breaks in html/xml string ("<br/>")
' Note: unclosed tags like <br> only would prevent a successful load of the xml document
wellformed = Replace(Replace(s, "</br>", "<br>"), "<br>", "<br/>")
End Function
Sub ShowParseError(pe As Object)
' Purpose: display possible parse error
' Note: localizes error occurrence also by indicating position
Dim ErrText$
With pe
ErrText = "Load error " & .ErrorCode & " xml file " & vbCrLf & _
Replace(.URL, "file:///", "") & vbCrLf & vbCrLf & _
.reason & _
"Source Text: " & .srcText & vbCrLf & vbCrLf & _
"Line No.: " & .Line & vbCrLf & _
"Line Pos.: " & .linepos & vbCrLf & _
"File Pos.: " & .filepos & vbCrLf & vbCrLf
End With
MsgBox ErrText, vbExclamation
End Sub
I tried something different, with splitting and joining and splitting again and looping trough array. I typed the text <b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> in cell A1:
Sub Macro1()
Dim MyWords As Variant
Dim i As Long
Dim MyDelimiter As String
Dim MyLen As Byte
MyDelimiter = "||" 'Choose 1 not common delimiter
MyLen = Len(MyDelimiter)
MyWords = Split(Join(Split(Range("A1").Value, "<b>"), MyDelimiter), "</b>")
For i = 0 To UBound(MyWords) Step 1
Debug.Print Mid(MyWords(i), InStr(1, MyWords(i), MyDelimiter) + MyLen, 99) 'Increase 99 if you are sure there will be longer texts between tags <b>..</b>
Next i
Erase MyWords
End Sub
I get this:
i have tried to simulate this on excel. please check my sample solution below.
Sub test()
Dim testString As String
Dim startPos As Integer
Dim endPos As Integer
Dim resultString As String
Dim str As String
testString = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b>"
'get the position of start tag
startPos = InStr(1, testString, "<b>") + 3
'get the position of end tag
endPos = InStr(startPos, testString, "</b>")
Do While Len(testString) > 1
'check if the start pos and end pos is correct
If startPos > 0 And endPos > startPos Then
'get the value in between the start tag and end tag
str = Mid(testString, startPos, endPos - startPos)
resultString = resultString + str + ","
'remove the value retrieved from the original string
testString = Mid(testString, endPos + 4)
startPos = InStr(1, testString, "<b>") + 3
endPos = InStr(startPos, testString, "</b>")
End If
Loop
End Sub
I have two strings like
str1= "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
str2="[def 2],[mno 5]"
The strings in str2 [def 2],[mno 5] should be deleted or replaced with "" in str1. result will be
str1="[abc 1],[ghi 3],[jkl 4]"
I tried replace function but not working giving full string str1
strorg1 = Replace(str1, str2,"")
Try this (sorry for not being able to format as code by now)
Option Explicit
Sub Main()
Dim str1 As String, str2 As String
Dim str As Variant
str1 = "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
str2 = "[def 2],[mno 5]"
str1 = "|" & str1 & "|"
For Each str In Split(str2, ",")
str1 = Replace(str1, str, "")
Next str
str1 = Replace(Replace(Replace(str1, ",,", ","), "|,", ""), ",|", "")
MsgBox str1
End Sub
This works i think:
Option Explicit
Sub gen()
Dim ReplaceList(1 To 5) As String
Dim str1 As String, strToReplace As Variant
Dim a() As String
Dim element As Long
str1 = "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
ReplaceList(1) = "[def 2]"
ReplaceList(2) = "[mno 5]"
a = Split(str1, ",")
For element = UBound(a) To 0 Step -1
For Each strToReplace In ReplaceList
If a(element) = strToReplace Then
a(element) = ""
End If
Next
Next
str1 = Join(a)
Debug.Print str1
End Sub
edit, i don't have access to Access, I hope this works, if not it should set you on the right track.
Try this one :
Sub Macro1()
Dim str1 As String
Dim str2 As String
Dim strTemp As String
Dim strTemp2 As String
Dim strOut As String
str1 = "[abc 1],[def 2],[ghi 3],[jkl 4],[mno 5]"
str2 = "[def 2],[mno 5]"
strOut = str1
Do
strTemp = Application.WorksheetFunction.Search("]", str2)
strTemp2 = Mid(str2, 1, strTemp + 1)
strOut = Replace(strOut, strTemp2, "")
str2 = Replace(str2, strTemp2, "")
Loop Until str2 = ""
End Sub
It will parse your str2, cut pieces inside [] and remove it from str1 one by one.
The output is what you expected, using excel 2010.
I was hoping someone could help me figure out why this script will not return the link names. I am trying to return a sub-string from 'http://textfiles.com/directory.html' which just writes the link names to the console, but I am struggling. The main problem - as far as I can see - is in the 'do until' loop. The working code outputs the html text to the console more for my sake than anything else (it does this successfully), but this feature may also help you guys understand the total picture I am facing. Maybe after seeing the code/ understanding my goal you guys can see where I am going wrong AND/OR suggest a better method for achieving my goal. Thanks a ton!
Imports System.IO
Imports System.Text
Module Module1
Sub Main()
Dim line As String = ""
Dim lowBound As String = "<a href="""
Dim highBound As String = """>"
Console.WriteLine("Grab link names from textfiles.com")
Console.WriteLine("")
Dim siteName As String = "http://textfiles.com/directory.html"
Dim tmpString As StringBuilder = New StringBuilder
My.Computer.Network.DownloadFile(siteName, "C:\~\VisualStudio\BeginnerPractice\TextFileDotCom_GrabLinkNames\TextFileDotCom_GrabLinkNames\bin\debug\directory.html", False, 500)
Dim myReader As StreamReader = New StreamReader("C:\~\VisualStudio\BeginnerPractice\TextFileDotCom_GrabLinkNames\TextFileDotCom_GrabLinkNames\bin\debug\directory.html")
While Not IsNothing(line)
line = myReader.ReadLine()
If Not IsNothing(line) Then
tmpString.Append(line)
End If
End While
Dim pageText As String = tmpString.ToString
Console.WriteLine(pageText)
Dim intCounter As Integer = 1
Do Until intCounter >= Len(pageText)
Dim checkSub As String = Mid(pageText, intCounter + 1, (Len(pageText) - intCounter))
Dim positLow As Integer = InStr(checkSub, lowBound)
Dim positHigh As Integer = InStr(checkSub, highBound)
If (positLow > 0 And positHigh > 0) And positLow < positHigh Then
Dim indexLow As Integer = checkSub.IndexOf(lowBound)
Dim indexHigh As Integer = checkSub.IndexOf(highBound)
Dim foundLink As String = checkSub.Substring(indexLow + Len(lowBound), indexHigh - Len(highBound))
Console.WriteLine(foundLink)
intCounter = intCounter + (Len(lowBound) + Len(highBound) + Len(foundLink) - 1)
Else
intCounter = Len(pageText)
End If
Loop
Console.ReadLine()
myReader.Close()
My.Computer.FileSystem.DeleteFile("C:\~\VisualStudio\BeginnerPractice\TextFileDotCom_GrabLinkNames\TextFileDotCom_GrabLinkNames\bin\debug\directory.html")
End Sub
End Module
This is the problem:
Code:
Dim findtext As String = "(?<=<hello>)(.*?)(?=</hello>)"
Dim myregex As String = TextBox1.Text
Dim doregex As MatchCollection = Regex.Matches(myregex, findtext)
MsgBox(doregex(0).ToString)
TextBox1:
<hello>1</hello>
<hello>2</hello>
<hello>3</hello>
So, when i run the code, it shows MsgBox with 1. Why only 1? Why not 2 and 3?
I added ? to .*, but it's still the same.
The MatchCollection contains multiple items but you are only retrieving the first one with doregex(0). Use a loop to get to the others:
Dim doregex As MatchCollection = Regex.Matches(myregex, findtext)
For Each match As Match In doregex
MsgBox(match.ToString)
Next
EDIT:
To combine the values, append them to a String within the loop before you use it:
Dim doregex As MatchCollection = Regex.Matches(myregex, findtext)
Dim matches As String = "" ' consider StringBuilder if there are many matches
For Each match As Match In doregex
matches = matches + match.ToString + " "
Next
MsgBox(matches)
Because you show only the first item in MatchCollection , you can use For Each loop to show all items like this :
For Each item In doregex
MsgBox(item.ToString)
Next
You can combine items with many way, belows one of them :
Dim result As String = String.Empty
For Each item In doregex
result = String.Format("{0} {1}", result, item)
Next
MsgBox(result)
Use LINQ:
Dim text_box_text = "<hello>1</hello>" & vbLf & "<hello>2</hello>" & vbLf & "<hello>3</hello>"
Dim findtext As String = "(?<=<hello>)(.*?)(?=</hello>)"
Dim my_matches_1 As List(Of String) = System.Text.RegularExpressions.Regex.Matches(text_box_text, findtext) _
.Cast(Of Match)() _
.Select(Function(m) m.Value) _
.ToList()
MsgBox(String.Join(vbLf, my_matches_1))
Also, with this code, you do not need to use the resource-consuming lookarounds. Change the regex to
Dim findtext As String = "<hello>(.*?)</hello>"
and use .Select(Function(m) m.Groups(1).Value) instead of .Select(Function(m) m.Value).
Am I reinventing the wheel here? Is there a better way to do this? This VBA function looks for the first instance of a string in the comment field of a form in Access containing 20 characters or less, no spaces, surrounded by (~) tildes, then returns it.
Public Function ParseComment(strComment As String) As String
' This function parses the comment field of the job entry dialog for (~) tilde
' surrounded text, then returns that text.
Dim intCounter As Integer
Dim intFirstChar As Integer
Dim intLastChar As Integer
Dim strResult As String
intFirstChar = 0
intLastChar = 0
intCounter = 0
Do While (intLastChar = 0) And (intCounter < Len(strComment))
intCounter = intCounter + 1
strCharacter = Mid(strComment, intCounter, 1)
If (strCharacter = "~") Then
If intFirstChar Then
intLastChar = intCounter
Else
intFirstChar = intCounter + 1
End If
End If
Loop
strResult = Mid(strComment, intFirstChar, intLastChar - intFirstChar)
If (intLastChar - intFirstChar <= 20) And (intFirstChar <> 0 Or intLastChar <> 0) And Not InStr(strResult, " ") Then
ParseComment = strResult
End If
End Function
Thanks much.
I would use InStr to find the first and second occurences of the ~ character, something like this, rather than looping manually:
Public Function ParseComment(strComment As String) As String
' This function parses the comment field of the job entry dialog for (~) tilde
' surrounded text, then returns that text.
Dim firstTilde As Integer
Dim secondTilde As Integer
Dim strResult As String
firstTilde = 0
secondTilde = 0
strResult = ""
firstTilde = InStr(strComment, "~")
If firstTilde > 0 Then
secondTilde = InStr(firstTilde + 1, strComment, "~")
If (secondTilde > 0) And (secondTilde < 20) Then
strResult = Mid(strComment, firstTilde, secondTilde)
If InStr(strResult, " ") = 0 Then
ParseComment = strResult
End If
End If
End If
End Function
[Disclaimer, I haven't tested this!]
Using the built-in functions might be a little quicker, but don't imagine it will make a critical difference...
Something like:
Public Function getTildeDelimStringPart(inputstring As String) As String
Dim commentStart As Long, commentEnd As Long
commentStart = InStr(1, inputstring, "~")
If commentStart = 0 Then ' no tilde
getTildeDelimStringPart = vbNullString
Exit Function
End If
commentEnd = InStr(1 + commentStart, inputstring, "~")
If commentEnd = 0 Then
getTildeDelimStringPart = vbNullString
Exit Function
End If
getTildeDelimStringPart = Mid(inputstring, commentStart, commentEnd - commentStart + 1)
End Function
I see everyone has given you some more ways to do this (instr is a great way, see Vicky's answer!), so I'll just list up some tips on optimizing your code:
Use Long instead of Integer. VBA will convert them to Long every time.
Default value for Int and Long is 0 in VBA, so no need to declare them so.
Use Mid$ instead of Mid
Using Instr() would be a very effecient way to find location of ~
Fun Tip: If you do want to evaluate each character, fastest way is numeric comparision:
if Asc(Mid$(strComment, intCounter, 1)) = 126 Then
This worked for me:
Public Function ParseComment(strComment As String) As String
Dim regex As Object ' VBScript_RegExp_55.RegExp
Dim regexmatch As Object ' VBScript_RegExp_55.MatchCollection
Set regex = CreateObject("VBScript_RegExp_55.RegExp")
With regex
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "(~[^ ~]{1,20}~)"
End With
Set regexmatch = regex.Execute(strComment)
If regexmatch.Count > 0 Then
ParseComment = regexmatch(0)
End If
End Function
You can add additional parsing at the end if you want to remove the tilde characters.
I tested it on the following string:
ABC~123aA%dwdD~CBA
the function returns ~123aA%dwdD~
Forgot to mention that this code requires VBScript Regular Expressions 5.5 which is located in %windir%\system32\vbscript.dll\3, although the code is late bound so you should just be able to drop it into your project.