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
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 have a comma separated lists in cells. All numbers are positive and between 1 and 10.
Example:
if I have in A1: (2,3,5,6), I would like to have missing numbers in B1:(1,4,7,8,9,10).
If A2: (1,10), then I would have in B2:(2,3,4,5,6,7,8,9)
If A3: (7), then I would have in B2:(1,2,3,4,5,6,8,9,10)
I searched for a solution online, but I couldn't find anything similar with comma separated numbers.
I'd be glad if I can have a solution here. Thanks.
Here is a user-defined function that should accomplish this... probably can be optimized.
Public Function MissingNumbers(ByVal numberList As String) As String
Dim temp As String
temp = Replace(numberList, "(", "")
temp = Replace(temp, ")", "")
Dim arr As Variant
arr = Split(temp, ",")
Dim newNumbers As String
newNumbers = "1,2,3,4,5,6,7,8,9,10,"
Dim i As Long
For i = LBound(arr) To UBound(arr)
newNumbers = Replace(newNumbers, arr(i) & ",", "")
Next
newNumbers = "(" & Left$(newNumbers, Len(newNumbers) - 1) & ")"
MissingNumbers = newNumbers
End Function
Just for fun demonstrating how to use negative filtering:
Function MissingList(ByVal numberList As String) As String
Dim given: given = Split(Mid(numberList, 2, Len(numberList) - 2), ",")
Dim series: series = GetSeries() ' i.e. numbers 1..10
Dim i As Long
For i = 0 To UBound(given)
series = Filter(series, given(i), False) ' << negative filtering
Next
MissingList = "(" & Replace(Join(series, ","), "0", "10") & ")"
End Function
As Filter executes a partial search in the 1..10 series, 10 has to be replaced temporarily by a unique 0.
Help function GetSeries()
Function GetSeries()
' Purpose: get numbers 1..10
Const LAST As Long = 10: Const FIRST = 1
Dim tmp: tmp = Application.Transpose(Evaluate("row(" & FIRST & ":" & LAST & ")"))
tmp(LAST) = 0 ' replace 10 by 0 as search item 1 would filter out value 10, too
GetSeries = tmp
End Function
A B C
1 numbers signs **Result**
2 *001* *alpha* 001-alpha
3 *001*111*221*104* *alpha*kappa*epislon*ETA* 001-alpha, 111-kappa, 221-epislon, 104-ETA
4 *001*085* *alpha*delta* 001-alpha, 085-delta
I'm trying to concatenate the values in columns A and B into the following format under the result section. Anything helps, thanks.
Formula solution
Using Textjoin and Filterxml function, of which Textjoin available in Office 365 or Excel 2019 and Filterxml available in Excel 2013 & later versions of Excel
In C2, array formula (confirm by pressing Ctrl+Shift+Enter) copied down :
=TEXTJOIN(", ",1,IFERROR(TEXT(FILTERXML("<a><b>"&SUBSTITUTE(A2,"*","</b><b>")&"</b></a>","//b"),"000")&FILTERXML("<a><b>"&SUBSTITUTE(B2,"*","</b><b>-")&"</b></a>","//b"),""))
I'm assuming this is doable with formulas but it might get unwieldy, so perhaps a UDF like this:
Public Function JoinNumbersAndSigns(ByVal numbersRng As Range, ByVal signsRng As Range) As String
Dim nums As String
nums = numbersRng.Cells(1).Value
nums = Mid$(nums, 2, Len(nums) - 2) ' remove leading and trailing *
Dim signs As String
signs = signsRng.Cells(1).Value
signs = Mid$(signs, 2, Len(signs) - 2) ' remove leading and trailing *
Dim tempNums As Variant
tempNums = Split(nums, "*")
Dim tempSigns As Variant
tempSigns = Split(signs, "*")
Dim i As Long
For i = LBound(tempNums) To UBound(tempNums)
Dim tempString As String
Dim sep As String
tempString = tempString & sep & tempNums(i) & "-" & tempSigns(i)
sep = ", "
Next i
JoinNumbersAndSigns = tempString
End Function
In Action:
The nums = Mid$(nums, 2, Len(nums) - 2) and similar line for signs could probably be made more robust, but should work given your current data.
Here's another approach using regular expressions ...
Option Explicit
Public Function Link(vNumbers As Range, vSigns As Range) As Variant
' ADD REFERENCE TO "Microsoft VBScript Regular Expressions 5.5"
Dim vRegEx As New RegExp
Dim vNumbersMatches As MatchCollection
Dim vSignsMatches As MatchCollection
Dim vCounter As Long
' The two parameters must only reference a single cell
If vNumbers.Cells.Count <> 1 Or vSigns.Cells.Count <> 1 Then
Link = CVErr(xlErrRef)
Exit Function
End If
' use regular expression to get the numbers
vRegEx.Pattern = "([0-9]+)"
vRegEx.Global = True
vRegEx.MultiLine = True
Set vNumbersMatches = vRegEx.Execute(vNumbers.Text)
' Use regular expression to get the signs
vRegEx.Pattern = "([^\*]+)"
vRegEx.Global = True
vRegEx.MultiLine = True
Set vSignsMatches = vRegEx.Execute(vSigns.Text)
' If the number of Numbers and Signs differs, then return an error
If vNumbersMatches.Count <> vSignsMatches.Count Then
Link = CVErr(xlErrValue)
Exit Function
End If
' Loop through the Numbers and Signs, appending each set
For vCounter = 0 To vNumbersMatches.Count - 1
Link = Link & vNumbersMatches.Item(vCounter) & "-" & vSignsMatches.Item(vCounter) & IIf(vCounter < vNumbersMatches.Count - 1, " ,", "")
Next
End Function
And the output ...
As long as there will always be a correlation between the number of elements in A & B this will work
Sub SplitandConcat()
' Declare working vars
Dim lRow As Long: lRow = 2
Dim sOutputString As String
Dim iWorkIndex As Integer
Dim CommaSpace As String
While ActiveSheet.Cells(lRow, 1) <> ""
CommaSpace = ""
'Split the incoming string on delimiter
arInput1 = Split(ActiveSheet.Cells(lRow, 1), "*")
arInput2 = Split(ActiveSheet.Cells(lRow, 2), "*")
' For each non blank item in the 1st array join the corresponding item int the second
For iWorkIndex = 0 To UBound(arInput1)
If arInput1(iWorkIndex) <> "" Then
ActiveSheet.Cells(lRow, 3) = ActiveSheet.Cells(lRow, 3) & CommaSpace & arInput1(iWorkIndex) & "-" & arInput2(iWorkIndex)
CommaSpace = ", "
End If
Next iWorkIndex
' check next row
lRow = lRow + 1
Wend
End Sub
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