Counting characters in Vb6 without including the spaces (string)
Just use Len() and Replace() to retrieve the length of your string with the spaces removed. For example:
Const strText As String = "The quick brown fox"
Debug.Print "Original length: " & Len(strText) ' => 23
Debug.Print "Length w/o spaces: " & Len(Replace$(strText, " ", "")) ' => 16
Function NonSpaceCount(ByRef Text As String) As Long
Dim I As Long
Dim S As Long
S = Len(Text)
Do While S
S = InStr(I + 1, Text, " ")
If S Then
NonSpaceCount = NonSpaceCount + S - (I + 1)
I = S
Else
NonSpaceCount = NonSpaceCount + Len(Text) - I
End If
Loop
End Function
Speed isn't always everything, but this should be faster than most alternatives.
Related
I have this string of word:
Two Thousand and Two Hundred and Point Thirty
I need a function to help me achieve:
Two Thousand and Two Hundred Point Thirty
I have tried using RemoveDuplicates function as per below but the result is:
Two Thousand Two Hundred Point Thirty
The result of the code below is:
Two Thousand Two Hundred Point Thirty
The code as below:
Function RemoveDuplicates(rng as Range) As String
Dim dict As Object
Dim var As Variant, v As Variant
Set dict = CreateObject("Scripting.Dictionary")
var = Split(rng.Value," and ")
For each v in var
If Not dict.Exists(v) Then
dict.Add v, v
End If
Next v
RemoveDuplicates = Join(dict.Keys, " ")
End Function
I felt that there is a need to put in a specific word as the delimiter as I would not want the double TWO to be deleted when i use the function. All I want is to remove all the "and" except for the 1st instance of the word but at the same time not wanting the code to think that the "and" in thousand is counted as the first instance.
Thank you very much for the help!
So I don't think you are far off in your approach. I have changed your function instead to take the string as an argument. Here is my attempt (probably not the best way to do this, but gets the desired result) :
Option Explicit
Function RemoveDuplicates(stringToRemove As String) As String
Dim arr As Variant
Dim i As Long, andCheck As Integer
Dim tempStr As String
arr = Split(stringToRemove, " ")
For i = LBound(arr) To UBound(arr)
' condition to be met if word is "and"
If arr(i) = "and" And andCheck >= 1 Then
' just continue, do not process
ElseIf arr(i) = "and" Then
tempStr = tempStr & arr(i) & " "
andCheck = andCheck + 1
Else
' rebuild string
tempStr = tempStr & arr(i) & " "
End If
Next i
RemoveDuplicates = Left(tempStr, Len(tempStr) - 1)
End Function
Running a test routine :
Sub test()
Dim inputStr As String: inputStr = "Two Thousand and Two Hundred and Point Thirty"
Debug.Print RemoveDuplicates(inputStr)
End Sub
Returns :
Two Thousand and Two Hundred Point Thirty
it's much easier with Instr() function
Option Explicit
Function RemoveDuplicates(rng As Range) As String
Dim firstAndPos As Long
firstAndPos = InStr(1, rng.Value, " and ", vbTextCompare) ' locate the position of the first instance of " and "
RemoveDuplicates = Left$(rng.Value, firstAndPos + Len(" and ")) & _
Replace(Mid$(rng.Value, firstAndPos + Len(" and ") + 1), " and ", " ") ' concatenate the part of string with the first instance with what follows it after having replaced all its instances of " and" with " "
End Function
But should you want and stick to the Dictionary approach, then iterate through var elements from the 2nd one on
Option Explicit
Function RemoveDuplicates(rng As Range) As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim var As Variant
var = Split(rng.Value, " and ")
Dim iv As Long
For iv = LBound(var) + 1 To UBound(var)
dict.Add var(iv), 0
Next
RemoveDuplicates = var(LBound(var)) & " and " & Join(dict.Keys, " ")
End Function
I am working on some software that cleans up data before sending it into another system. The data comes from all around the world and contains a variety of characters that have to be replaced. For example ‘, : ; #
The system that accepts the parsed data has very strict character set. It allows
the letters A to Z (upper case only)
the numerals 0 to 9
the special characters / -. Space < =
The data arrives in Excel spreadsheets so I have written the following code in a visual basic macro.
fhl_str contains the data to be cleansed
fhl_str = Replace(fhl_str, ",", " ")
fhl_str = Replace(fhl_str, "'", " ")
fhl_str = Replace(fhl_str, ":", " ")
fhl_str = Replace(fhl_str, ";", " ")
fhl_str = ucase(fhl_str)
Now, each time a new unwanted character arrives we have to add a new line of code. e.g. fhl_str = Replace(fhl_str, "#", " ")
My question is
Could I reverse the logic so that the macro looks for A to Z and 0 to 9 and deletes anything else. That way my code would be future proof for new unwanted characters.
Thanks
If you want to replace bad characters with a single space:
Sub KeepOnlyTheGood()
Dim i As Long, L As Long, v As String, CH As String
Dim r As Range
For Each r In Selection
t = ""
v = r.Value
L = Len(v)
For i = 1 To L
CH = Mid(v, i, 1)
If CH Like "[0-9A-Z]" Or CH = "/" Or CH = "-" Or CH = "." Or CH = " " Or CH = "<" Or CH = "=" Then
t = t & CH
Else
t = t & " "
End If
Next i
r.Value = t
Next r
End Sub
Here's some VBA that will do it if you find regex difficult to understand. It uses the ASCII code to determine the only characters to allow. If your scope changes you can modify the ASCII numbers in the Case statement.
Public Function RemoveSpecial(s As String) As String
Dim sResult As String
Dim nIndex As Integer
s = UCase$(s)
For nIndex = 1 To Len(s)
Select Case Asc(Mid$(s, nIndex, 1))
Case 65 To 90, 45 To 57, 32, 60 To 61
sResult = sResult & Mid$(s, nIndex, 1)
Case Else
sResult = sResult & " "
End Select
Next
RemoveSpecial = sResult
End Function
Usage:
Debug.Print RemoveSpecial("TeSt<>=.##")
or something like:
Range("A1") = RemoveSpecial("TeSt<>=.##")
ASCII Codes
Very simple I believe just can't get it myself
I'm taking a string example "88888<>88888<>88888<>" and all I want to do is remove the "<>" take the part after and place on 2nd line of a list so it would become
88888
88888
88888
This code does the work for you using .IndexOf() and .SubString(). There are other shorter ways too, a lot more actually but I wrote this so you can know what's happening in every step and know the exact solution.
Dim FInalString As String
Dim String_ As String = "88888<>8888888<>88888<>"
'now find the position of first <>
Dim firstsign_ As Integer = String_.IndexOf("<", 0)
'add string upto that point in the textbox
FInalString = "1. " & String_.Substring(0, firstsign_)
'now find the position of second <>
Dim secondSign_ As Integer = String_.IndexOf("<", firstsign_ + 2) 'here, not 0 because we have to skip the first one
' MsgBox(secondSign_)
'add the string upto that point in the textbox
FInalString = FInalString & vbCrLf & "2. " & String_.Substring(firstsign_ + 2, secondSign_ - firstsign_ - 2) 'vbCrLf means go to next line now
'now find the third sign, last
Dim lastsign_ As Integer = String_.IndexOf("<", secondSign_ + 2)
'add to the string
FInalString = FInalString & vbCrLf & "3. " & String_.Substring(secondSign_ + 2, lastsign_ - secondSign_ - 2)
MsgBox(FInalString)
Output:
88888
8888888
88888
I have no idea what this has to do with a WebClient. But this should work as you need.
Dim str As String = "88888<>88888<>88888<>"
Dim strarr As String() = str.Split("<>")
Dim result As String = ""
For i As Integer = 0 To strarr.Length
result &= (i + 1) & ". " & strarr(i)
Next
I have a situation where I want to have an input box where a string like "C123q23C456a45" is entered. The pattern will remain the same, so it will always be C,3 numbers,A-z,number( this number can be either 2 or 3 digits).
I want to split this string with the C's, so the example above will be split into:
C456a45 and C123q23. this output is showed in a message box in the form of C123 has 23 of q and c456 has 45 of a.
if that makes sense.
how do i approach this?
thanks appreciate it
If you can live without VBA to do this, you can use these formulas if you have the string you want to split in A1:
=LEFT(A1;FIND("C";A1;FIND("C";A1)+2)-1) for C123q23
=RIGHT(A1;LEN(A1)-LEN(LEFT(A1;FIND("C";A1;FIND("C";A1)+2)-1))) for C456a45
** UPDATED **
Sub Macro1()
Dim strFirstSplitA As String, str1A As String, str2A As String
Dim strA As String, strAA As String, strAAA As String
Dim str1B As String, strB As String, strBB As String, strBBB As String
Dim strMsgBoxA As String, strMsgBoxB As String
str1A = InStr(1, Range("A1"), "C") + 2
str2A = InStr(str1A, Range("A1"), "C") ' FIND("C";A1)+2)-1)
strFirstSplitA = Left(Range("A1"), str2A - 1)
strA = Left(strFirstSplitA, 4)
strAA = Right(strFirstSplitA, Len(strFirstSplitA) - 4)
strAAA = Right(strAA, Len(strAA) - Len(Left(strAA, 1)))
strMsgBoxA = strA & " has " & strAAA & " of " & Left(strAA, 1)
' C123 has 23 of q
str1B = Right(Range("A1"), Len(Range("A1")) - Len(strFirstSplitA))
strB = Left(str1B, 4)
strBB = Right(str1B, Len(str1B) - 4)
strBBB = Right(strBB, Len(strBB) - Len(Left(strBB, 1)))
strMsgBoxB = strB & " has " & strBBB & " of " & Left(strBB, 1)
' c456 has 45 of a
MsgBox strMsgBoxA & " and " & strMsgBoxB
End Sub
Not tested, but something like this:
a = Split("C123q23C456a45", "C")
For i = 1 To Ubound(a)
Debug.Print Left$(a(i), 3), Mid$(a(i), 5)
Next
Example
Say I have a string:
"I say ""Hello world"" and she says ""Excuse me?"""
VBA will interpret this string as:
I say "Hello world" and she says "Excuse me?"
A more complex example:
I have a string:
"I say ""Did you know that she said """"Hi there!"""""""
VBA interprets this string as:
I say "Did you know that she said ""Hi there!"""
If we remove "I say "
"Did you know that she said ""Hi there!"""
we can continue parsing the string in vba:
Did you know that she said "Hi there!"
Problem
Ultimately I want some function, sBasicQuote(quotedStringHierarchy as string), which returns a string containing the next level up in the string hierarchy.
E.G.
dim s as string
s = "I say ""Did you know that she said """"Hi there!"""""""
s = sBasicQuote(s) ' returns 'I say "Did you know that she said ""Hi there!"""'
s = sBasicQuote(s) ' returns 'Did you know that she said "Hi there!"'
s = sBasicQuote(s) ' returns 'Hi there!'
I just can't figure out an algorithm that would work with this... You almost need to replace all double quotes, but when you've replaced the nth double quote you have to skip to the n+1th douple quote?
How does one implement this in VBA?
You could do something like this
Public Sub test()
Dim s As String
s = "I say ""Did you know that she said """"Hi there!"""""""
Debug.Print DoubleQuote(s, 0)
Debug.Print DoubleQuote(s, 1)
Debug.Print DoubleQuote(s, 2)
End Sub
Public Function DoubleQuote(strInput As String, intElement As Integer) As String
Dim a() As String
strInput = Replace(strInput, String(2, Chr(34)), String(1, Chr(34)))
a = Split(strInput, chr(34))
DoubleQuote = a(intElement)
End Function
Another slightly modified version is a little more accurate
`Public Function DoubleQuote(strInput As String, intElement As Integer) As String
Dim a() As String
Dim b() As String
Dim i As Integer
ReDim b(0)
a = Split(strInput, Chr(34))
' ***** See comments re using -1 *******
For i = 0 To UBound(a) - 1
If Len(a(i)) = 0 Then
b(UBound(b)) = Chr(34) & a(i + 1) & Chr(34)
i = i + 1
Else
b(UBound(b)) = a(i)
End If
ReDim Preserve b(UBound(b) + 1)
Next i
DoubleQuote = b(intElement)
End Function`
I think the following will return what you are looking for in your nested quote example. Your first example is not really a situation of nested quotes.
Option Explicit
Sub NestedQuotes()
Const s As String = "I say ""Did you know that she said """"Hi there!"""""""
Dim COL As Collection
Dim Start As Long, Length As Long, sTemp As String, V As Variant
Set COL = New Collection
sTemp = s
COL.Add sTemp
Do Until InStr(sTemp, Chr(34)) = 0
sTemp = COL(COL.Count)
sTemp = Replace(sTemp, String(2, Chr(34)), String(1, Chr(34)))
Start = InStr(sTemp, Chr(34)) + 1
Length = InStrRev(sTemp, Chr(34)) - Start
sTemp = Mid(sTemp, Start, Length)
COL.Add sTemp
Loop
For Each V In COL
Debug.Print V
Next V
End Sub
My Solution
I spent some more time thinking and came up with this solution.
Function sMineDoubleQuoteHierarchy(s As String) As String
'Check the number of quotes in the string are even - sanity check
If (Len(s) - Len(Replace(s, """", ""))) Mod 2 <> 0 Then sMineDoubleQuoteHierarchy = "Error - Odd number of quotes found in sMineDoubleQuoteHierarchy() function": Exit Function
'First thing to do is find the first and last *single* quote in the string
Dim lStart, lEnd, i As Long, fs As String
lStart = InStr(1, s, """")
lEnd = InStrRev(s, """")
'After these have been found we need to remove them.
s = Mid(s, lStart + 1, lEnd - lStart - 1)
'Start at the first character
i = 1
Do While True
'Find where the next double quote is
i = InStr(1, s, """""")
'if no double quote is found then concatenate with fs with the remainder of s
If i = 0 Then Exit Do
'Else add on the string up to the char before the ith quote
fs = fs & Left(s, i - 1)
'Replace the ith double quote with a single quote
s = Left(s, i - 1) & Replace(s, """""", """", i, 1)
'Increment by 1 (ensuring the recently converted double quote is no longer a single quote
i = i + 1
Loop
'Return fs
sMineDoubleQuoteHierarchy = s
End Function
What's going on in this solution?
The first part of the process is removing the first and last single quote from the string and returning the text between them. Then we loop through the string replacing each instance of "" and replacing it with ". Each time we do this we skip to the next character to unsure strings like """" go to "" instead of ".
Does anyone else have a better/more compact solution?
Edit
After all the suggestions in this forum I settled with this. It's got some extra error trapping to find validate nested strings.
Public Function DoubleQuoteExtract(ByVal s As String, Optional ByRef ErrorLevel As Boolean) As String
'This effectively parses the string like BASIC does by removing incidents of "" and replacing them with "
'SANITY CHECK - Check even number of quotes
Dim countQuote As Double
countQuote = Len(s) - Len(Replace(s, """", ""))
'Calculate whether or not quote hierarchy is correct:
'"..." - Is okay - Count Quotes = 2 - Count Quotes / 2 = 1
'""..."" - Is not okay - Count Quotes = 4 - Count Quotes / 2 = 2
'"""...""" - Is okay - Count Quotes = 6 - Count Quotes / 2 = 3
'""""..."""" - Is not okay - Count Quotes = 8 - Count Quotes / 2 = 4
'etc.
'Ultimately: IF CountQuotes/2 = Odd The string hierarchy is setup fine
' IF CountQuotes/2 = Even, The string Hierarchy is setup incorrectly.
Dim X As Double: X = countQuote / 2
Dim ceil As Long: ceil = Int(X) - (X - Int(X) > 0)
If ceil Mod 2 <> 0 Then sDoubleQuoteExtract = "#Error - Incorrect number of double quotes forming an incomplete hierarchy.": GoTo ErrorOccurred
'If an odd number of quotes are found then they cannot be paired correctly, thus throw error
If countQuote Mod 2 <> 0 Then sDoubleQuoteExtract = "#Error - Odd number of quotes found in sMineDoubleQuoteHierarchy() function": GoTo ErrorOccurred
'Find the next incident of single quote. Trim the string to this
s = Mid(s, InStr(1, s, String(1, Chr(34))))
'replace all instances of "" with "
s = Replace(s, String(2, Chr(34)), String(1, Chr(34)))
'Finally trim off the first and last quotes
DoubleQuoteExtract = Mid(s, 2, Len(s) - 2)
ErrorLevel = False
Exit Function
ErrorOccurred:
ErrorLevel = True
End Function