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'm trying to read a .csv to work with it in an .accdb
The file has ; as delimiter and "" as string qualifier.
Young and naive as I was I just split the file at the delimiter:
Set oFSO = New FileSystemObject
Set oStream = oFSO.OpenTextFile(sFilePath, ForReading)
Do Until oStream.AtEndOfStream
sLine = oStream.ReadLine
sArray = Split(sLine, ";")
....
Now I got a line that reads:
"String";"Str;ing";0;0;0;"String"
So I have delimiter inside one of the strings which makes the code above not work. Any ideas how to solve this?
EDIT:
I've found someone with a similar problem, only with a comma as delimiter. And they solved it using regular expressions.
The problem: I'm absolutely not good with regular expressions. In the example the used this expression and code:
Function regLine(sLine As String) As String
Dim oRegEx As RegExp
Set oRegEx = New RegExp
oRegEx.IgnoreCase = True
oRegEx.Global = True
' Pattern: ",(?=([^"]*"[^"]*")*(?![^"]*"))"
oRegEx.Pattern = ",(?=([^" & Chr(34) & "]*" & Chr(34) & "[^" & Chr(34) & "]*" & Chr(34) & ")*(?![^" & Chr(34) & "]*" & Chr(34) & "))"
regLine = oRegEx.Replace(sLine, ";")
End Function
So I don't really understand the expression. My first idea was to replace the comma with a semicolon but that didn't work.
Option Explicit
Dim line
line ="""String"";""Str;ing"";0;0;0;""String"""
WScript.Echo line
Dim aFields
With New RegExp
.Pattern = "(""[^""]*"")?;"
.Global = True
aFields = Split(.Replace(line, "$1"&Chr(0)),Chr(0))
End With
Dim field
For Each field In aFields
WScript.Echo field
Next
Code is .vbs, but shows how to use the regular expression to replace semicolons not enclosed in quotes with a null character and use the null character to split the line into its fields.
I solved the problem now by writing a loop, that deletes the delimiter if it is in a string.
Function fixLine(sLine As String)
Dim i As Long
Dim bInString As Boolean
bInString = False
fixLine = ""
For i = 1 To Len(sLine)
If Mid(sLine, i, 1) = Chr(34) Then
If bInString Then
bInString = False
Else
bInString = True
End If
End If
If bInString And Mid(sLine, i, 1) = ";" Then
Else
fixLine = fixLine & Mid(sLine, i, 1)
End If
Next
End Function
It kind of feels quick and dirty and I'm not sure about the performance but it works.
EDIT:
I also worked with theabove example I found. It replaces the delimiter in a line outside of strings. So I replaced the delimiter with Chr(0) which I know won't apear in a line and then split at the new delimiter.
Function regLine(sLine As String) As String()
Dim oRegEx As RegExp
Dim sLine2() As String
Set oRegEx = New RegExp
oRegEx.Global = True
'Pattern: ";(?=([^"]*"[^"]*")*(?![^"]*"))"
oRegEx.Pattern = ";(?=([^" & Chr(34) & "]*" & Chr(34) & "[^" & Chr(34) & "]*" & Chr(34) & ")*(?![^" & Chr(34) & "]*" & Chr(34) & "))"
sLine2 = oRegEx.Replace(sLine, Chr(0))
regLine = Split(sLine2, Chr(0))
End Function
My first question is: Is there any case where a ";" in the string values is a valid string? If so, I don't see any way other than manually verifying the data.
If not, how large is the input file? If it's not too big (for various definitions of "too" :-) ) then just manually scan it for errors.
If it is very large, I'd simple write a preprocesser program that reads the string values then deletes any ";" in those where it occurs. Such a program is only about a dozen lines long. Then run the clean file into Access.
So, I had previously asked a question that was successfully answered (here: Parsing JSON (US BLS) in VBA from MS Access)
The new response I get that differs from the original question is that I've added a request to capture calculations. I've tried adding as a collection and scripting dictionary like footnotes but I see the format is not quite the same, and therefore I think it results in null when I try to gather the 1,3,6 and 12 month changes. I'd like to have some help figuring out how to capture those changes in the following response:
{
"status":"REQUEST_SUCCEEDED",
"responseTime":64,
"message":["BLS does not produce net change calculations for Series WPU381103"],
"Results":
{
"series":
[
{
"seriesID":"WPU381103",
"data":
[
{
"year":"2014",
"period":"M12",
"periodName":"December",
"value":"98.9",
"footnotes":
[
{
"code":"P",
"text":"Preliminary. All indexes are subject to revision four months after original publication."
}
],
"calculations":
{
"net_changes":{},
"pct_changes":
{
"1":"0.0",
"3":"0.1",
"6":"0.0",
"12":"-0.7"
}
}
},
{
"year":"2014",
"period":"M11",
"periodName":"November",
"value":"98.9",
"footnotes":
[
{
"code":"P",
"text":"Preliminary. All indexes are subject to revision four months after original publication."
}
],
"calculations":
{
"net_changes":{},
"pct_changes":
{
"1":"0.1",
"3":"-0.4",
"6":"0.0",
"12":"-0.7"
}
}
},...
You will notice that there is a part now that says calculations, and seperates values by net changes, and percent changes. I am trying to get the percent changes within the "1", "3", "6" and "12" data items.
Here is the current code I'm that does NOT find calculations but captures all the other data:
response = http.responseText
jsonSource = response
I = 0
Dim jsonData As Scripting.Dictionary
Set jsonData = JSON.parse(jsonSource)
Dim responseTime As String
responseTime = jsonData("responseTime")
Dim results As Scripting.Dictionary
On Error Resume Next
Set results = jsonData("Results")
Dim series As Collection
On Error Resume Next
Set series = results("series")
Dim seriesItem As Scripting.Dictionary
For Each seriesItem In series
Dim seriesId As String
seriesId = seriesItem("seriesID")
Dim Data As Collection
Set Data = seriesItem("data")
Dim dataItem As Scripting.Dictionary
For Each dataItem In Data
Dim Year As String
Year = dataItem("year")
I = 1 + I
Dim Period As String
Period = dataItem("period")
Dim periodName As String
periodName = dataItem("periodName")
Dim Value As String
Value = dataItem("value")
Dim footnotes As Collection
Set footnotes = dataItem("footnotes")
Dim footnotesItem As Scripting.Dictionary
For Each footnotesItem In footnotes
Dim Code As String
Code = footnotesItem("code")
Dim text As String
text = footnotesItem("text")
Next footnotesItem
Next dataItem
Next seriesItem
Pretty straight forward. Remember, the JSON module implements JavaScript arrays as collections and objects as Scripting.Dictionary instances.
In your context, [..].calculations, [..].calculations.net_changes and [..].calculations.pct_changes are all objects so they are all converted to Dictionary objects.
So in your code, after the For Each footnotesItem In footnotes: [..]: Next footnotesItem block (therefore, above & before the Next dataItem line), you could add the following lines:
Dim calculations As Scripting.Dictionary
Dim sIndent As String
Dim calcNetChanges As Scripting.Dictionary
Dim calcPctChanges As Scripting.Dictionary
Dim varItem As Variant
Set calculations = dataItem("calculations")
sIndent = String(4, " ")
Set calcNetChanges = calculations("net_changes")
Debug.Print Year & ", " & Period & " (" & periodName & ") - Net Changes:"
If calcNetChanges.Count > 0 Then
For Each varItem In calcNetChanges.keys
Debug.Print sIndent & CStr(varItem) & ": " & calcNetChanges.Item(varItem)
Next varItem
Else
Debug.Print sIndent & "(none)"
End If
Set calcPctChanges = calculations("pct_changes")
Debug.Print Year & ", " & Period & " (" & periodName & ") - Pct Changes:"
If calcPctChanges.Count > 0 Then
For Each varItem In calcPctChanges.keys
Debug.Print sIndent & CStr(varItem) & ": " & calcPctChanges.Item(varItem)
Next varItem
Else
Debug.Print sIndent & "(none)"
End If
which, with the json data provided, should output something like this:
2014, M12 (December) - Net Changes:
(none)
2014, M12 (December) - Pct Changes:
1: 0.0
3: 0.1
6: 0.0
12: -0.7
2014, M11 (November) - Net Changes:
(none)
2014, M11 (November) - Pct Changes:
1: 0.1
3: -0.4
6: 0.0
12: -0.7
If you want to access the items of calculations.net_changes and calculations.pct_changes directly by their keys (known in advance), you would replace the two For Each varItem blocks by, respectively:
If calcNetChanges.Exists("1") Then Debug.Print "1: " & calcNetChanges.Item("1")
If calcNetChanges.Exists("3") Then Debug.Print "3: " & calcNetChanges.Item("3")
If calcNetChanges.Exists("6") Then Debug.Print "6: " & calcNetChanges.Item("6")
If calcNetChanges.Exists("12") Then Debug.Print "12: " & calcNetChanges.Item("12")
[..]
If calcPctChanges.Exists("1") Then Debug.Print "1: " & calcPctChanges.Item("1")
If calcPctChanges.Exists("3") Then Debug.Print "3: " & calcPctChanges.Item("3")
If calcPctChanges.Exists("6") Then Debug.Print "6: " & calcPctChanges.Item("6")
If calcPctChanges.Exists("12") Then Debug.Print "12: " & calcPctChanges.Item("12")
Finally, you should note that in the json data you're giving as the example, percentages (i.e. values of items for [..].calculations.net_changes & [..].calculations.pct_changes) are provided as strings, therefore you would probably want to convert those in Double (or Single) data using Val() to perform math or other numerical operations on them, e.g.:
Dim pctChange_1 As Double, pctChange_3 As Double
Dim pctChange_6 As Double, pctChange_12 As Double
pctChange_1 = 0#
pctChange_3 = 0#
pctChange_6 = 0#
pctChange_12 = 0#
If calcPctChanges.Exists("1") Then pctChange_1 = CDbl(Val(calcPctChanges.Item("1")))
If calcPctChanges.Exists("3") Then pctChange_3 = CDbl(Val(calcPctChanges.Item("3")))
If calcPctChanges.Exists("6") Then pctChange_6 = CDbl(Val(calcPctChanges.Item("6")))
If calcPctChanges.Exists("12") Then pctChange_12 = CDbl(Val(calcPctChanges.Item("12")))
Declare calculations as a Scripting.Dictionary and its pct-changes as Scripting.Dictionary as well. Append the following code snippet after the code for footnotes. HTH
Dim calculations As Scripting.Dictionary
Set calculations = dataItem("calculations")
Dim pct_changes As Scripting.Dictionary
Set pct_changes = calculations("pct_changes")
Dim pct_change As Variant
For Each pct_change In pct_changes
Debug.Print pct_change & ":" & pct_changes(pct_change)
Next pct_change
The Debug.Print pct_change & ":" & pct_changes(pct_change) produces the following result for the first calculations set:
1:0.0
3:0.1
6:0.0
12:-0.7
I have code that will list tables names, how can I export this to a text file?
For Each tbl In db.TableDefs
If Left$(tbl.Name, 4) <> "MSys" Then
Debug.Print tbl.Name & " " & tbl.DateCreated & " " & _
tbl.LastUpdated & " " & tbl.RecordCount
See the MSDN article on how to create a text file:
http://msdn.microsoft.com/en-us/library/aa265018(v=vs.60).aspx
Modified slightly for your needs, you will have to tweak it to define db and TableDefs etc:
Sub CreateAfile
Dim fs as Object, a as Object
Dim lineText as String
#Create and open text file for writing:
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\testfile.txt", True)
'#Iterate over your TableDefs
For Each tbl In db.TableDefs
If Left$(tbl.Name, 4) <> "MSys" Then
lineText = tbl.Name & " " & tbl.DateCreated & " " & _
tbl.LastUpdated & " " & tbl.RecordCount
'# Adds a line to the text file
a.WriteLine(lineText)
End If
Next
'#Close the textfile
a.Close
End Sub
You can use simple File I/O to write to a textfile. MSDN: Write# Statement
Here is the example from that page:
Open "TESTFILE" For Output As #1 ' Open file for output.
Write #1, "Hello World", 234 ' Write comma-delimited data.
Write #1, ' Write blank line.
Dim MyBool, MyDate, MyNull, MyError
' Assign Boolean, Date, Null, and Error values.
MyBool = False: MyDate = #2/12/1969#: MyNull = Null
MyError = CVErr(32767)
' Boolean data is written as #TRUE# or #FALSE#. Date literals are
' written in universal date format, for example, #1994-07-13#
'represents July 13, 1994. Null data is written as #NULL#.
' Error data is written as #ERROR errorcode#.
Write #1, MyBool; " is a Boolean value"
Write #1, MyDate; " is a date"
Write #1, MyNull; " is a null value"
Write #1, MyError; " is an error value"
Close #1 ' Close file.
Change the file name, and extension, to, for example, "C:\SomeFolder\myfile.txt".
There are other, more sophisticated, ways to do this, including using the FileSystemObject as shown in the link David provided.
This will work as a straight copy/paste. Just change the output file name to whatever you want. It outputs the metadata you requested line by line toa .txt
Dim db As DAO.Database
Set db = CurrentDb
Dim filename As String
filename = "C:\Users\Scotch\Desktop\now\t.txt" 'add your file name here
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fs, f, ts, s
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile filename 'Create a file
Set f = fs.GetFile(filename)
Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
For Each tbl In db.TableDefs
If Left$(tbl.name, 4) <> "MSys" Then
ts.Write tbl.name & " " & tbl.DateCreated & " " & _
tbl.LastUpdated & " " & tbl.RecordCount & vbNewLine
End If
Next
ts.Close
I need to remove line breaks from the beginning of a memo type records. I dont want to use the replace function as it would remove all line breaks from the record which is not desired. Its only the line breaks at the beginning of the field that I am interested in removing.
Furthermore, the my records do not always begin with a line break so I cant really use text positioning, the solution would be to look for line break at the beginning instead of always expecting it at the beginning.
If Len(string) > 0 Then
Do While Left(string,1)= chr(13) Or Left(string,1)= chr(10) or Left(string,1) = " "
string = Right(string, len(string)-1)
Loop
End If
This will check to make sure the string isn't empty, then runs a simple loop to remove the left-most character as long as it is either a CR (chr(13)), LF (chr(10)), or a space (" ").
Once the loop hits the first character that doesn't match the criteria, it stops and you have the desired result of trimming all extra CR, LF, and space characters only from the beginning of the string.
Since it's relatively short, I just put it in the event procedure where needed, you could also modify it to be a public function in a module if you see fit.
Replace does not replace all occurences when you use the count argument: http://office.microsoft.com/en-us/access/HA012288981033.aspx
You can test it like so:
s1 = vbCrLf & "abc"
s2 = "ab" & vbCrLf & "c"
MsgBox "---" & IIf(Left(s1, 2) = vbCrLf, Replace(s1, vbCrLf, "", , 1), s1)
MsgBox "---" & IIf(Left(s2, 2) = vbCrLf, Replace(s2, vbCrLf, "", , 1), s2)
Improving upon what SBinVA wrote
The following code does not need the if statement and it is easy to expand to more character (space, tabs, etc.).
(It also assumes line breaks can originate from a file that can comes from other systems, so vbCr and vbLf are used separately, which takes care of all scenarios.)
Public Function trimCrOrLf(ByVal s As String) As String
Dim firstChar As String
firstChar = Left(s, 1)
Do While InStr(vbCr & vbLf, firstChar) > 0
s = Mid(s, 2)
firstChar = Left(s, 1)
Loop
trimCrOrLf = s
End Function
Consider a SQL UPDATE statement to discard only those CRLF at the beginning of each memo field.
UPDATE MyTable SET MyTable.memo_field = Mid([memo_field],3)
WHERE (((MyTable.memo_field) Like Chr(13) & Chr(10) & "*"));
Private Sub TestLineFeed()
Dim strString$, strTestChar, booStartsWith_CR As Boolean
strString = Chr$(13) & "some text"
strTestChar = "2"
'strTestChar = Chr$(13) ''This is a CR.
booStartsWith_CR = (Left(strString, 1) = strTestChar)
Debug.Print "-----"
Debug.Print "Raw: " & strString
Debug.Print booStartsWith_CR
If booStartsWith_CR Then
strString = Mid(strString, 2, 100)
End If
Debug.Print "-----"
Debug.Print "New: " & strString
End Sub
Note alternatives for strTestChar so you can see the action. You should notice "-----" in your Immediate Window is followed by a CR, thus a blank line; and this can be removed. Mid(strString, 2, 100) will need some tweaking, but the idea is to copy over your memo string without the first character.
I would use a function like this. It's fairly straight-forward and easily adapted to other circumstances. For example, to remove leading spaces too, add another test to the if (c = vbCr) line.
Function LTrimCRLF(s As String) As String
Dim index As Integer, start As Integer, strLen As Integer
Dim c As String
strLen = Len(s)
index = 1
start = -1
Do While (index <= strLen) And (start = -1)
c = Mid(s, index, 1)
If (c = vbCr) Or (c = vbLf) Then
index = index + 1
Else
start = index
End If
Loop
If start = -1 Then
LTrimCRLF = ""
Else
LTrimCRLF = Mid(s, start)
End If
End Function
Here's a test routine:
Sub TestLTrimCRLF()
Dim withWS As String, noWS As String, blank As String, onlyWS As String
withWS = vbCrLf & " this string has leading white space"
noWS = "this string has no leading white space"
onlyWS = vbCrLf & " " & vbCrLf & " "
blank = ""
Say "with WS: {" & LTrimCRLF(withWS) & "}"
Say "no WS: {" & LTrimCRLF(noWS) & "}"
Say "only WS: {" & LTrimCRLF(onlyWS) & "}"
Say "blank: {" & LTrimCRLF(blank) & "}"
End Sub
BTW, I tried looking at your sample data, but it says the document is not available. Maybe you need to make it public or something?
My contribution to VBA trimwhitespace() function, loop finds for first non-whitespace index, splits a string, then same thing for trailing whitespaces. Left+Right functions are run only once. If you need just leftTrim or rightTrim it's easy to introduce new arguments or separate functions.
Function trimWhitespace(str As String) As String
Dim idx As Long
Dim ch As String
' LeftTrim
If Len(str) > 0 Then
idx = 1
ch = Mid(str, idx, 1)
Do While ch = Chr(13) Or ch = Chr(10) Or ch = " "
idx = idx + 1
ch = Mid(str, idx, 1)
Loop
If (idx > 1) Then str = Right(str, Len(str) - idx)
End If
' RightTrim
idx = Len(str)
If idx > 0 Then
ch = Mid(str, idx, 1)
Do While ch = Chr(13) Or ch = Chr(10) Or ch = " "
idx = idx - 1
ch = Mid(str, idx, 1)
Loop
If (idx < Len(str)) Then str = Left(str, idx)
End If
trimWhitespace = str
End Function
This will trim all leading and trailing spaces, carriage returns, tabs, and other non-printable characters.
Public Function TrimSpecial(InputString As Variant) As String
' This will trim leading/trailing spaces and non-printable characters from the passed string.
Dim i As Integer
Dim str As String
On Error GoTo ErrorHandler
str = InputString
For i = 1 To Len(str)
If Asc(Mid(str, i, 1)) > 32 And Asc(Mid(str, i, 1)) < 127 Then
' Valid character found. Truncate leading characters before this.
str = Mid(str, i)
Exit For
End If
Next i
For i = Len(str) To 1 Step -1
If Asc(Mid(str, i, 1)) > 32 And Asc(Mid(str, i, 1)) < 127 Then
' Valid character found. Truncate trailing characters after this.
str = Mid(str, 1, i)
Exit For
End If
Next i
TrimSpecial = str
Exit_Function:
Exit Function
ErrorHandler:
MsgBox "Error #" & Err.Number & " - " & Err.Description & vbCrLf & "in procedure TrimSpecial"
GoTo Exit_Function
Resume Next
Resume
End Function
You can use this routine to test it:
Public Sub Test_TrimSpecial()
' Run this to test the TrimSpecial function.
Dim x As String
x = vbCrLf & " " & vbTab & " ab cd" & vbCrLf & vbTab & " xyz " & vbCr & vbCrLf
Debug.Print "-----"
Debug.Print ">" & x & "<"
Debug.Print "-----"
Debug.Print ">" & TrimSpecial(x) & "<"
Debug.Print "-----"
End Sub
Like "*" & Chr(13) & Chr(10)
(Access used carriage return + line feed, characters 13 and 10, for a new line).
To remove the carriage return/line feed, change the query to an update query and enter the following in the Update to line:
Replace([FieldName], Chr(13) & Chr(10), "")
or
Replace([FieldName], Chr(10),"")
Replace([FieldName], Chr(13),"")