//:celebrity/:channel[:id='239']/:linear/:schedules[:scheduleId='TV_239_2036-05-11_03:00:00.000' and :startTime='2036-05-11T03:00:00.000+0000']/:authorization[:linearAuth='false' and :linearSubAuth='false' and :authCode='NA']
I have one column with multiple XPaths. I need JSON version for this so I need to delete all colon characters (:) but not in dates (not in scheduleId and startTime). It means delete them only when before colon is: "/" or "[" or " "
How to do that using VBA code? Thanks
Assuming you are working in Column A ,try this:
Sub Demo()
Columns("A:A").Replace What:="/:", Replacement:="/", LookAt:=xlPart
Columns("A:A").Replace What:="[:", Replacement:="[", LookAt:=xlPart
Columns("A:A").Replace What:=" :", Replacement:=" ", LookAt:=xlPart
End Sub
EDIT1: Code based on the comment
Sub Demo()
i = WorksheetFunction.Match("iXpath", Range("A1:Z1"), 0)
Columns(i).Replace What:="/:", Replacement:="/", LookAt:=xlPart
Columns(i).Replace What:="[:", Replacement:="[", LookAt:=xlPart
Columns(i).Replace What:=" :", Replacement:=" ", LookAt:=xlPart
End Sub
Here, I am searching for iXpath in the range A1:Z1, you can change this range as required.
EDIT2: Code to work on all worksheets
Sub Demo()
Dim ws As Worksheet, i As Long
For Each ws In ThisWorkbook.Worksheets
With ws
i = WorksheetFunction.Match("iXpath", .Range("A1:Z1"), 0)
.Columns(i).Replace What:="/:", Replacement:="/", LookAt:=xlPart
.Columns(i).Replace What:="[:", Replacement:="[", LookAt:=xlPart
.Columns(i).Replace What:=" :", Replacement:=" ", LookAt:=xlPart
End With
Next
End Sub
Try this...
"MyString" is the string with your content
"MyReplacer" is what shoud replace the colons (can be space, nothing or any other character)
MyString = "//:celebrity/:channel[:id='239']/:linear/:schedules[:scheduleId='TV_239_2036-05-11_03:00:00."
MyReplacer = " " 'here add what must replace the ":"
MyString = Replace(MyString," :",MyReplacer)
MyString = Replace(MyString,"[:",MyReplacer)
MyString = Replace(MyString,"/:",MyReplacer)
You could also do something like this. I based this on the input shown, so the position of the = may change, there are 2 in the example.
Function testReplace(strInput As String) As String
testReplace = Join(Split(strInput, ":"), "") & "=" & Split(strInput, "=")(2)
End Function
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've been working on a spread sheet to allow my team to manage our workload more effectively, whilst the business is developing a new tool. Anyway, what the sheet does is inject information, then at the click of a button, it populates an OFT email template so that the info can be sent out.
Problem is, we rely heavily on bullet lists for our emails, and I'm really struggling to find a way of adding bullets effectively from an ActiveX Textbox.
At the moment, I have a button which adds the follow to a text box:
[bullets]
* Bullet 1
* Bullet 2
* Bullet 3
[/bullets]
I then have Replace statements that look for strings and it replaces them with the appropriate HTML tags. Here's the code:
' Add HTML formatting to text updates so it displays correctly in the email.
LatestUpdate.Text = Replace(LatestUpdate, "[bullets]", "<ul>")
LatestUpdate.Text = Replace(LatestUpdate, "[/bullets]", "</ul>")
LatestUpdate.Text = Replace(LatestUpdate, "* ", "<li>")
LatestUpdate.Text = Replace(LatestUpdate, vbCrLf, "<br>")
The problem I'm having, is that non-technical people are using this document, so I would really like to have it in such a way were they don't have to look at the markup, but can simple add bullets straight from the textbox.
I was originally thinking about replacing "* " with "< li >" however, that doesn't add the correct < ul > tags, so it's not actually a bullet list within the email.
Can anyone help in simplifying this process for the end users please? I'm really stuck.
The holy grail would be to enable rich text formatting on the textbox, but I don't believe that's possible from all the research I've done?
TIA.
Based on your last comment, what you are looking for is not just a bullet point in your textbox but indentation as well. So here is an attempt at it:
First add the below in your <textbox>_KeyUp function:
Private Sub txtBulletPoints_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim STRING_LENGTH As Long: STRING_LENGTH = 49
Dim aLine() As String
Dim aLineSpace() As String
Dim iC As Integer
Dim sText As String
Dim bUpdate As Boolean
' Only do this if there is a string to work with
If Len(Me.txtBulletPoints.Text) > 0 Then
' Set initial values
aLine = Split(Me.txtBulletPoints.Text, vbCrLf)
bUpdate = False
' First lets indent the last line if we need to
If Left(aLine(UBound(aLine)), 2) = "- " Then
For iC = LBound(aLine) To UBound(aLine)
If iC = UBound(aLine) Then
sText = sText & vbTab & aLine(iC)
Else
sText = sText & aLine(iC) & vbCrLf
End If
Next
Me.txtBulletPoints.Text = sText
End If
' Now the tricky bit. Check if we have reached the end of the
' line so that we can indent the text into the next line
If (Len(aLine(UBound(aLine))) >= STRING_LENGTH) And (InStr(1, aLine(UBound(aLine)), vbTab) = 1) Then
For iC = LBound(aLine) To UBound(aLine)
If iC = UBound(aLine) Then
aLineSpace = Split(aLine(iC), " ")
' As we have to indent the last bullet point line, call the finction to do that
sText = sText & SetIndentsInString(aLine(iC), STRING_LENGTH)
Else
sText = sText & aLine(iC) & vbCrLf
End If
Next
Me.txtBulletPoints.Text = sText
End If
End If
End Sub
Now add the below UDF where your form code is (essentially at the same place where your <textbox>_KeyUp function is):
Function SetIndentsInString(ByVal sString As String, ByVal iIndentLen As Long) As String
Dim iC As Long
Dim iLastTab As Long: iLastTab = 0
Dim aSpace() As String
Dim aTab() As String
Dim sCurString As String
' Check if the string is the same as what it was last
' time (sLastString is a private module variable initialised
' to "" when the form is activated)
If Replace(sString, vbTab, "") = Replace(sLastString, vbTab, "") Then
' Its the same string so lets return it as is
SetIndentsInString = sString
Else
' Its not the same string so set initial values
sLastString = sString
SetIndentsInString = ""
' Loop to see how many lines we have based on number of TABs in the string
Do While InStr(iLastTab + 1, sString, vbTab) > 0
iLastTab = iLastTab + InStr(iLastTab + 1, sString, vbTab)
Loop
' If there is only 1 TAB, simply indent the line
If iLastTab = 1 Then
aSpace = Split(sString, " ")
SetIndentsInString = Mid(sString, 1, Len(sString) - Len(aSpace(UBound(aSpace)))) & vbTab & " " & aSpace(UBound(aSpace))
Else
' More then 1 TAB.. damn!. Ok well lets work it
aTab = Split(sString, vbTab)
sCurString = aTab(UBound(aTab))
' Check if the last line of our bullet point has more characters then allowed in a line
If Len(sCurString) >= iIndentLen Then
' It does. Now loop through all the lines in our bullet point and set the last character in a new line with indent
aSpace = Split(sCurString, " ")
For iC = LBound(aTab) To UBound(aTab)
If iC = UBound(aTab) Then
SetIndentsInString = SetIndentsInString & Mid(sCurString, 1, Len(sCurString) - Len(aSpace(UBound(aSpace)))) & vbTab & " " & aSpace(UBound(aSpace))
Else
SetIndentsInString = SetIndentsInString & aTab(iC) & vbTab
End If
Next
Else
' It doesnt. Loop through and send the string back
SetIndentsInString = sString
End If
End If
End If
End Function
Now in the same module, make the following declaration at the top:
Private sLastString As String
Essentially the above will act like a bullet point as it would be in a Rich Text box. Things to remember is that you will have to set STRING_LENGTH to the number of characters your textbox will take in a given bullet point line (you will have to play around with that). Below is a screen print of how it worked for me
I've come up with a bit of a weird situation. I have a string that was entered into a form from a webpage. I noticed that the string wasn't behaving as expected when I was trying to apply a filter.
The crux of the matter is depending on how I view the string it appears differently.
Form View - "523548"
Datasheet View - " 523548"
Raw Sql - " 523548"
Actually, when I view the datasheet value it appears as "523548 " but copies as " 523548".
Asc(Left(string),1) tells me the first character is Chr9 (Tab Key)
I am really stuck to find out why this is happening or more importantly, what I can do to correct it.
Thanks!
Dave.
I'd use the Trim() function here. Although the link is for Excel, it's the same syntax in Access.
Use this function when you write the value to the table, and you can use this function to clean up your current data as well. This should remove phantom tabs, as well as spaces.
Thanks for the tips. I found this function and added in a couple of items to suit my needs.
' Strip Illegal Characters
' http://www.utteraccess.com/wiki/index.php/Strip_Illegal_Characters
' Code courtesy of UtterAccess Wiki
' Licensed under Creative Commons License
' http://creativecommons.org/licenses/by-sa/3.0/
'
' You are free to use this code in any application,
' provided this notice is left unchanged.
'
' rev date brief descripton
' 1.0 2010-10-23 Writing files to disk that contain illegal file characters can cause sometimes obscure error message(s)
'
Public Function fStripIllegal(strCheck As String, Optional strReplaceWith As String = "") As String
On Error GoTo StripIllErr
'illegal file name characters included in default string are ? [ ] / \ = + < > :; * " , '
Dim intI As Integer
Dim intPassedString As Integer
Dim intCheckString As Integer
Dim strChar As String
Dim strIllegalChars As String
Dim intReplaceLen As Integer
If IsNull(strCheck) Then Exit Function
strIllegalChars = "?[]/\=+<>:;,*" & Chr(34) & Chr(39) & Chr(32) & Chr(9) 'add/remove characters you need removed to this string
intPassedString = Len(strCheck)
intCheckString = Len(strIllegalChars)
intReplaceLen = Len(strReplaceWith)
If intReplaceLen > 0 Then 'a character has been entered to use as the replacement character
If intReplaceLen = 1 Then 'check the character itself isn't an illegal character
If InStr(strIllegalChars, strReplaceWith) > 0 Then
MsgBox "You can't replace an illegal character with another illegal character", _
vbOKOnly + vbExclamation, "Invalid Character"
fStripIllegal = strCheck
Exit Function
End If
Else 'only one replacement character allowed
MsgBox "Only one character is allowed as a replacement character", _
vbOKOnly + vbExclamation, "Invalid Replacement String"
fStripIllegal = strCheck
Exit Function
End If
End If
If intPassedString < intCheckString Then
For intI = 1 To intCheckString
strChar = Mid(strIllegalChars, intI, 1)
If InStr(strCheck, strChar) > 0 Then
strCheck = Replace(strCheck, strChar, strReplaceWith)
End If
Next intI
Else
For intI = 1 To intPassedString
strChar = Mid(strIllegalChars, intI, 1)
If InStr(strCheck, strChar) > 0 Then
strCheck = Replace(strCheck, strChar, strReplaceWith)
End If
Next intI
End If
fStripIllegal = Trim(strCheck)
StripIllErrExit:
Exit Function
StripIllErr:
MsgBox "The following error occured: " & err.Number & vbCrLf _
& err.Description, vbOKOnly + vbExclamation, "Unexpected Error"
fStripIllegal = strCheck
Resume StripIllErrExit
End Function
Well, adjust your routine to not include the tab for new entries.
The old entries you can adjust with Replace:
NewValue = Replace([OldValue], Chr(9), "")
The answer is probably really simple - I just can't come up with the right search term, I suspect.
I have a form that opens another form, displaying any employee record that matches the search as entered You can search by surname, given name, or employee ID (using separate buttons); it gives you a little message box if your search turns up nothing.
The code works fine, except for the usual problem with handling apostrophes in names ("O'Neill," "O'Brien," etc.) I found a really simple apostrophe handling function, but when I try to use the function in the search query it still throws up a 3075 runtime error, and I'm not sure why. It only throws up the runtime error with apostrophe-containing searches, so I feel like the function maybe isn't doing what I think it is.
I am happy to entertain solutions that involve "using this function but adding more quotation marks (or whatever)" as well as whole new ideas. I'd prefer to use something like this function, though, because it's so small and thus it'll be much faster and cleaner to replace the search-by-name code each place that it appears.
This is the code that works fine:
Private Sub btnSearchSurname_Click()
Dim frm As Form
Dim strSearch As String
strSearch = "[List_Employees.Surname] like '" & Me.EmpSurname & "*'"
strSearch = strSearch & " AND [CurrentEmployee] = " & True
DoCmd.OpenForm "Employee_Entry_Extended_Certs", , , strSearch, , acHidden
Set frm = Forms("Employee_Entry_Extended_Certs")
If frm.Recordset.RecordCount > 0 Then
frm.Visible = True
Else
MsgBox ("Employee not found. Try the 'all' button to see if they're inactive. If that doesn't work, please check for typos and try again.")
DoCmd.Close acForm, "Employee_Entry_Extended_Certs"
Call OpenPayrollCloseRest
End If
DoCmd.Close acForm, "Find_An_Employee"
I'm trying to use this simple public function to handle apostrophes:
Public Function adhHandleQuotes(ByVal varValue As Variant, Optional Delimiter As String = "'") As Variant
' Replace all instances of a string delimiter with TWO instances,
' thereby handling the darned quote issue once and for all. Also,
' surround the string with the delimiter, as well.
' Returns Null if the String was Null, otherwise
' returns the String with all instances of strDelimiter
' replaced with two of each.
adhHandleQuotes = strDelimiter & Replace(varValue, strDelimiter, strDelimiter & strDelimiter) & strDelimiter
End Function
I modified the search code to use the function by inserting three lines lines in place of the first "strSearch = " line:
Dim strSearch As String
Dim strTerm As String
strTerm = adhHandleQuotes(Me.EmpSurname)
strSearch = "[List_Employees.Surname] like '" & strTerm & "*'"
strSearch = strSearch & " AND [CurrentEmployee] = " & True
DoCmd.OpenForm "Employee_Entry_Extended_Certs", , , strSearch, , acHidden
And this is the runtime error dialogue box:
Why do you even need a function? Just simply incorporate a Double Quotes, my hack is to use Chr(34).
Private Sub btnSearchSurname_Click()
Dim frm As Form
Dim strSearch As String
strSearch = "[List_Employees.Surname] Like " & Chr(34) & Me.EmpSurname & "*" & Chr(34)
strSearch = strSearch & " AND [CurrentEmployee] = True"
DoCmd.OpenForm "Employee_Entry_Extended_Certs", , , strSearch, , acHidden
Set frm = Forms("Employee_Entry_Extended_Certs")
If frm.Recordset.RecordCount > 0 Then
frm.Visible = True
Else
MsgBox ("Employee not found. Try the 'all' button to see if they're inactive. If that doesn't work, please check for typos and try again.")
DoCmd.Close acForm, "Employee_Entry_Extended_Certs"
Call OpenPayrollCloseRest
End If
DoCmd.Close acForm, "Find_An_Employee"
End Sub
You might want to try this:
Access VBA, unescaped single quotes, Replace(), and null
Rather than doubling your apostrophe, it surrounds it with double quotes.
I'm looking to find a way to remove stop words using a function in Visual Basic inside my Access DB.
Today I'm just doing several replace but I know it's not the right way as I wouldn't know if I'm removing the Stop Word as a word or within a word.
Any help would be great, I just cannot find any way to do this on VB.
Okay, you mean something like this, right?
OutputString = Replace("They answered the question", "the", "")
This replaces all occurrences of "the" from the phrase, including part of the word "They".
The simplest solution would be to put spaces before and after the word to replace:
OutputString = Replace("They answered the question", " the ", "")
This works for the phrase in my above example, but it won't work when the word occurs at the beginning or at the end of the phrase.
For these cases, you need to do more. Something like this:
Public Function RemoveStopWords( _
ByVal Phrase As String, _
ByVal WordToRemove As String _
) As String
Dim RetVal As String
Dim Tmp As String
'remove the word in the middle of the phrase
RetVal = Replace(Phrase, " " & WordToRemove & " ", " ")
'remove the word at the beginning
Tmp = WordToRemove & " "
If Left(RetVal, Len(Tmp)) = Tmp Then
RetVal = Mid(RetVal, Len(Tmp) + 1)
End If
'remove the word at the end
Tmp = " " & WordToRemove
If Right(RetVal, Len(Tmp)) = Tmp Then
RetVal = Left(RetVal, Len(RetVal) - Len(Tmp))
End If
RemoveStopWords = RetVal
End Function
This works as long as the words in the phrase are always separated with blanks.
When there can be other separators than blanks, you have to do even more.
For example, instead of hardcoding the blanks in the function, you could loop over a list of separators and execute the function for each one.
I won't show this as code now, but you get the idea.