My String (strSQL) Value is 1,2,3,,4 and My result shows blank between 3 and 4 due to Double comma (,,). My Code is Following:-
strParts = Split(strSQL, ", ")
For intCounter = LBound(strParts()) To UBound(strParts())
Me.Controls("cmd" & intCounter).Visible = True
Me.Controls("cmd" & intCounter).Caption = strParts(intCounter)
Next intCounter
You can replace a double (,,) by a single one (,) before splitting:
strSQL = Replace(strSQL, ",,", ",")
Or you use a separate index:
strParts = Split(strSQL, ",")
Dim index As Long
Dim counter As Long
For index = LBound(strParts()) To UBound(strParts())
If Len(Trim(strParts(index))) > 1 Then
counter = counter + 1
Me.Controls("cmd" & counter).Visible = True
Me.Controls("cmd" & counter).Caption = strParts(index)
End If
Next index
As you also could have tripled commas, just ignore the empty entries:
Dim Part As String
strParts = Split(strSQL, ",")
For intCounter = LBound(strParts()) To UBound(strParts())
Part = Trim(strParts(intCounter))
If Part <> "" Then
Me.Controls("cmd" & Part).Visible = True
Me.Controls("cmd" & Part).Caption = Part
Else
Me.Controls("cmd" & Part).Visible = False
End If
Next
I think the best way to do this is to "sanitize" your string to remove extra commas before splitting. However, as #Gustaf notes, you could have more than 2 commas in a row. So a possible solution is to iteratively remove extra commas until you don't have any. Such a function looks like this:
' given a string that contains consecutive commas (e.g. abc,,def,,,ghi),
' removes all but the first commas (e.g. abc,def,ghi
Public Function RemoveDuplicateCommas(ByVal s As String) As String
Do While InStr(1, s, ",,", vbBinaryCompare) > 0
s = Replace(s, ",,", ",")
Loop
RemoveDuplicateCommas = s
End Function
To use this function, do something like this:
strSQL = "1,2,3,,4,,,5"
strSQL = RemoveDuplicateCommas(strSQL)
?strSQL
1,2,3,4,5
?join(split(strsql, ","), ",")
1,2,3,4,5
Related
Newbie here. I have an HTML source code and would like to look for string in between header tags <h1></h1>, <h2></h2>till <h5></h5> and then convert the text to lower case except acronyms or abbreviations (these are all capitals in 2 or more characters). And make sure that all country names in between use proper case.
As an example: It will find <h1>HR Policies and Procedures for Hiring - argentina LTD</h1>
It will convert it to:<H1>HR policies and procedures for hiring - Argentina LTD</H1>
I've tried a user defined function for Excel VBA found online: CapIt(A2). It uses Search, Split and Join. I'm not able to put them together to come up with the result. Would appreciate very much your help. Thank you.
Code I saw online as initial reference:
Function Capit(s As String)
Dim v As Variant, j As Long
v = Split(s, " ") ' separates the words
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capit = Join(v, " ") ' joins the words
End Function
'Added this code below, can we use the results to lowercase the string and exclude the output in this function
Function FindAcronyms(yourWord As String)
Dim I As Integer
Dim ctr As Integer
FindAcronyms = Null
For I = 1 To Len(yourWord)
If Asc(Mid(yourWord, I, 1)) <= 90 And _
Asc(Mid(yourWord, I, 1)) >= 65 Then
If ctr > 0 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
ctr = ctr + 1
Else
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1) & ", "
End If
ctr = 0
End If
Next
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
If Right(FindAcronyms, 2) = ", " Then
FindAcronyms = Left(FindAcronyms, Len(FindAcronyms) - 2)
End If
End Function
'the final look would be something like this
Sub TitleChange()
'define array
myarray = Range("A1:A100")
' Define the pattern
Dim pattern As String: pattern = "<h*>*</h*>" 'looks for the header tags
Dim f As Variant
For Each f In myarray
If f Like pattern = True Then Capital (f) 'changes all string to lower case except countries (to retain proper case) and acronyms (to retain uppercase)
Next f
End Sub
You can include the countries in an array
Sub Test()
Debug.Print Capital("HR Policies and Procedures for Hiring - argentina LTD")
End Sub
Function Capital(ByVal s As String)
Dim a, v As Variant, j As Long
a = Array("Argentina", "Egypt", "Enland")
v = Split(s, " ")
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbLowerCase)
If Not IsError(Application.Match(v(j), a, 0)) Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capital = Join(v, " ")
End Function
Added UDF that parses HTML code, used the Sub Test above as UDF Capital and UDF to bring together. Welcome suggestions to make it cleaner or more efficient
Dim rng As Range, cell As Range
Set rng = Range("A1:A5")
' Define the pattern
Dim pattern As String: pattern = "*<h?>*</h?>*"
' Check each item against the pattern
For Each cell In rng
If (cell Like pattern = True) Then
cell.Offset(0, 16).Value = cell.Value
cell.Offset(0, 16).Value = joinCell(Capital(StripHTML(cell)), cell.Offset(0, 0).Value) 'used UDF for striping innertext, applying rules and joining back string
End If
Next cell
End Sub
I am trying to use this code to pick comma seperated numbers from ExcUID text box of form and then feed them into tblExcIndivList table.
However what I am trying to do it to split ex: 123,1213 into lines and put them in seperate rows of UID column of tblExcIndivList table but it gets saved as 1231213 in the same cell.
Sub Upd_UID()
Dim var As Variant
Dim i As Long
var = Split(Forms.Agen_Report.ExcUID.Value, vbNewLine)
CurrentDb.Execute "DELETE * FROM tblExcIndivList;", dbFailOnError
For i = 0 To UBound(var)
CurrentDb.Execute Replace("INSERT INTO tblExcIndivList ( UID ) VALUES ( '#V' );", "#V", var(i)), dbFailOnError
Next i
End Sub
Please help.
You are not splitting correctly your string, you say it is comma-separated (i.e. 123,1213) and try to split it with vbNewLine. You should specify the comma as separator:
var = Split(Forms.Agen_Report.ExcUID.Value, ",")
This will get you past this error and split correctly the input. However I cant make sure whether your query is well-formed.
I think you need something like this.
Option Explicit
Dim aCell As Range
Private Sub UserForm_Initialize()
'~~> Change Sheet1 to the relevant sheet name
'~~> Change A1:E1 to the relevant range
For Each aCell In ThisWorkbook.Sheets("Sheet1").Range("A1:E1")
If InStr(1, aCell.Value, ",") Then _
ComboBox1.AddItem Split(aCell.Value, ",")(0)
Next aCell
'~~> Remove duplicates
RemoveDuplicates ComboBox1
End Sub
Private Sub ComboBox1_Click()
Dim tmpStr As String
ComboBox2.Clear
For Each aCell In ThisWorkbook.Sheets("Sheet1").Range("A1:E1")
If InStr(1, aCell.Value, ",") Then _
tmpStr = Split(aCell.Value, ",")(0)
If Trim(ComboBox1.Value) = Trim(tmpStr) Then _
ComboBox2.AddItem aCell.Value
Next aCell
End Sub
'~~> Procedure to remove duplicates
Private Sub RemoveDuplicates(cmb As ComboBox)
Dim a As Integer, b As Integer, c As Integer
a = cmb.ListCount - 1
Do While a >= 0
For b = a - 1 To 0 Step -1
If cmb.List(b) = cmb.List(a) Then
cmb.RemoveItem b
a = a - 1
End If
Next b
a = a - 1
Loop
End Sub
I have a GPS truck tracking DB i am working with and I want to remove all the Letters from a certain column. Or if it is easier extrapolate all the Numbers and put them in their own column. The Left, Right, Mid will not work because the numeric value for each number position changes line to line.Screen Shot of DB
I am not sure this is even possible in access or if I will have to pass the data through python to do what I am wanting.
try
InStr( startPosition, "abcdefg", "c" )
returns the character position of "c" in "abcdefg", 0 if no match.
Either use vba to programmatically process the records or use queries directly but not as efficient.
ex. (step by step to make it clearer)
SELECT IIf( InStr(1,[description],"odo:")>0, "found", "not found" )
AS Result FROM MyTable;
replace "found" with:
Mid( [description], InStr(1,[description],"odo:")+3 )
this will chop off everything on the left "On Duty, odo:", "Driving, odo:".
Since it is not posible to store into temporary variables in queries, just use up several InStr() to find "odo:" and possibly " Miles" then use them again to compute the length. For small number of records this will be fine, otherwise better use VBA for efficiency.
The following are two methods to return only digits - but you need to tell us which field(s) you want to parse.
Option Compare Database
Option Explicit
Function Test_This()
Dim strIN As String
strIN = "On Duty, odo: 245678.9,"
MsgBox "Loop Method:" & vbCrLf & "Input String: " & strIN & vbCrLf & "Output String: " & Method_Loop(strIN)
MsgBox "Parse Method:" & vbCrLf & "Input String: " & strIN & vbCrLf & "Output String: " & Method_Parse(strIN)
End Function
Function Method_Parse(InValue As String) As String
Dim i As Integer
Dim i2 As Integer
Dim iLen As Integer
Dim strOut As String
iLen = Len(InValue)
i2 = 0
strOut = ""
' Assume delimiter is colon + space
i = InStr(1, InValue, ": ")
If i = 0 Then
MsgBox "No starting delimiter (: ) for '" & InValue & "'", vbOKOnly, "No Start Delimiter"
Method_Parse = ""
Exit Function
End If
i2 = InStr(i, InValue, ",")
If i2 = 0 Then
MsgBox "No ending delimiter (,) for '" & InValue & "'", vbOKOnly, "No End Delimiter"
Method_Parse = ""
Exit Function
End If
strOut = Mid(InValue, i + 2, i2 - i - 2)
Method_Parse = strOut
End Function
Function Method_Loop(InValue As String) As String
Dim i As Integer
Dim i2 As Integer
Dim iLen As Integer
Dim strOut As String
iLen = Len(InValue)
i2 = 0
strOut = ""
For i = 1 To iLen
' If you can have a period that is not part of the number,
' and your number's can have decimal places, then modify the code
' to check if 'IsNumeric' for the prefeeding and following characters.
If (IsNumeric(Mid(InValue, i, 1))) Or (Mid(InValue, i, 1) = ".") Then
strOut = strOut & Mid(InValue, i, 1)
End If
Next i
Method_Loop = strOut
End Function
Looks like from that screenshot you can use:
X = InStr(0, Description, ":" ) 'Gets the position of the first semicolon
Y = InStr(X, Description, "," ) 'Gets the position of the following comma
Then you can use those two numbers in a Mid statement:
Z = Mid(Description, X + 1, Z - 1)
That should give you the odometer reading.
If you need other numbers, just continue on with that logic.
i have an access form consisting of a textbox , i need to check the last word of it and if this word is one of many words (array or a table column ) do an action , and this check will occurs in after_update event , something like
Private Sub textbox_AfterUpdate()
Dim txt As String
Dim lastword As String
txt = TextBox.Value
lastword= Right(txt, Len(txt) - InStrRev(txt, " "))
if lastword in (array() or column in a table) then
' do an action
End If
End Sub
we can also us an external function , could you help me with it ??
Looks like you got the function for the last word already... Now for the search in an array and table use this:
Function isInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
and
Function isColumnName(stringToBeFound As String, tableName As String) As Boolean
Dim db As Database
Dim rs1 As DAO.Recordset
Set db = CurrentDb()
Set rs1 = db.OpenRecordset(tableName)
isColumnName = False
Dim fld As DAO.Field
do until rs1.EOF
if rs1.Fields.Item(0).Value = stringToBeFound then
isColumnName = true
exit loop
end if
rs1.moveNext
loop
Set fld = Nothing
End Function
usage:
if isInArray(lastWord, youArray) or isColumnName(lastWord, "yourTable")
MsgBox "The word is already used!"
end if
How about something like this:
Private Sub TextBox1_AfterUpdate()
Dim txtStr As String
Dim vWords, v
txtStr = TextBox1.Text
If InStr(txtStr, " ") > 0 Then
txtStr = Right(txtStr, Len(txt) - InStrRev(txt, " "))
End If
vWords = Split("word1 word2 word3 word4", " ") ' fill vWords with the words you need
For Each v In vWords
If v = txtStr Then
' do an action
Exit For
End If
Next
End Sub
I am trying to import a comma delimted csv file in access. The issue i am having is that one of the columns "Amount" has commas in the data itself e.g. "1,433.36". And there will always be commas in this data.
How can I import is successfully?
Sample Data:
sjonn,one,"1,855.9"
ptele,two,344.0
jrudd,one,334.8
Thanks in advance
I would change the delimiter to a different character, like a pipe "|".
if the DoCmd.TransferText does not work for you, then you can define a method to do that 'manually' :
Set fs = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = fs.GetFile("import.txt")
Set objFileTextStream = objFile.OpenAsTextStream(1, 2)
objFileTextStream.skipLine 'if the file contains the header
Do While objFileTextStream.AtEndOfStream <> True
strLine = objFileTextStream.ReadLine 'read a line
strLinePart = split(strLine,",") 'Split the line using the , delimiter
firstField = strLinePart(0)
secondField = strLinePart(1)
thirdField = strLinePart(2)
strSQL = "INSERT INTO myTable Values('"& firstField &"','"& secondField &"','"& thirdField &"')"
conn.Execute strSQL
Loop
objFileTextStream.Close: Set objFileTextStream = Nothing
Set fs = Nothing
conn.Close: Set conn = Nothing
Save the file as a tab delimited text file and import that instead.
reading the file using input handles the quotes for you
Dim f1 As String
Dim f2 As String
Dim f3 As String
Open "d:\test.txt" For Input As #1
Input #1, f1, f2, f3
Debug.Print f1, f2, f3
Input #1, f1, f2, f3
Debug.Print f1, f2, f3
Close #1 '
giving
sjonn one 1,855.9
ptele two 344.0
I once encountered the problem and this is another method that might help, it however splits the lines themselves, i.e. you must split the string first into lines before using this method
Its also assumed that its contained in a Module named Module1
''Perfoms a smart split that takes care of the ""
Public Function SmartSplit(Str As String) As Variant
''New collection
Dim Quote As String
Dim Delimiter As String
Dim MyString As String
Dim Sample As String
Dim StrCollection As New Collection
Dim Array_1() As String
Dim HasSeenQuote As Boolean
Dim index As Long
Quote = "" & CStr(Chr(34))
Delimiter = "" & CStr(Chr(44))
HasSeenQuote = False
Array_1 = Split(Str, Delimiter)
For index = LBound(Array_1) To UBound(Array_1)
Sample = Array_1(index)
If Module1.StartsWith(Sample, Quote, False) Then
HasSeenQuote = True
End If
''We append the string
If HasSeenQuote Then
MyString = MyString & "," & Sample
End If
''We add the term
If Module1.EndsWith(Sample, Quote, False) Then
HasSeenQuote = False
MyString = Replace(MyString, Quote, "")
MyString = Module1.TrimStartEndCharacters(MyString, ",", True)
MyString = Module1.TrimStartEndCharacters(MyString, Quote, True)
StrCollection.Add (MyString)
MyString = ""
GoTo LoopNext
End If
''We did not see a quote before
If HasSeenQuote = False Then
Sample = Module1.TrimStartEndCharacters(Sample, ",", True)
Sample = Module1.TrimStartEndCharacters(Sample, Quote, True)
StrCollection.Add (Sample)
End If
LoopNext:
Next index
''Copy the contents of the collection
Dim MyCount As Integer
MyCount = StrCollection.Count
Dim RetArr() As String
ReDim RetArr(0 To MyCount - 1) As String
Dim X As Integer
For X = 0 To StrCollection.Count - 1 ''VB Collections start with 1 always
RetArr(X) = StrCollection(X + 1)
Next X
SmartSplit = RetArr
End Function
''Returns true of false if the string starts with a string
Public Function EndsWith(ByVal Str As String, Search As String, IgnoreCase As Boolean) As Boolean
EndsWith = False
Dim X As Integer
X = Len(Search)
If IgnoreCase Then
Str = UCase(Str)
Search = UCase(Search)
End If
If Len(Search) <= Len(Str) Then
EndsWith = StrComp(Right(Str, X), Search, vbBinaryCompare) = 0
End If
End Function
''Trims start and end characters
Public Function TrimStartEndCharacters(ByVal Str As String, ByVal Search As String, ByVal IgnoreCase As Boolean) As String
If Module1.StartsWith(Str, Search, IgnoreCase) Then
Str = Right(Str, (Len(Str) - Len(Search)))
End If
If Module1.EndsWith(Str, Search, IgnoreCase) Then
Str = Left(Str, (Len(Str) - Len(Search)))
End If
TrimStartEndCharacters = Str
End Function
''Returns true of false if the string starts with a string
Public Function StartsWith(ByVal Str As String, Search As String, IgnoreCase As Boolean) As Boolean
StartsWith = False
Dim X As Integer
X = Len(Search)
If IgnoreCase Then
Str = UCase(Str)
Search = UCase(Search)
End If
If Len(Search) <= Len(Str) Then
StartsWith = StrComp(Left(Str, X), Search, vbBinaryCompare) = 0
End If
End Function