How I can split the string with variable delimiter count:
s = "a1 b2 c d e"
into array:
arr(1) = "a1"
arr(2) = "b2"
arr(4) = "c"
arr(5) = "d"
arr(6) = "e"
The split-function does not give a desired result:
arr = Split(s, " ")
Thanks!
Use WorksheetFunction.Trim to remove leading and trailing spaces, as well as extra inner spaces.
Dim s As String '<~ don't use Str
s = "a b c d e"
s = WorksheetFunction.Trim(s)
The pure VBA approach is to use a loop and the replace function
Public Function Dedup(ByVal ipSource As String, ByVal ipDedup As String) As String
Dim mySource As String
mySource = ipSource
Dim MyDedupDedup As String
MyDedupDedup = ipDedup & ipDedup
Do
DoEvents ' Always put a doevents in a Do loop
Dim myLen As Long
myLen = Len(mySource)
mySource = Replace(mySource, MyDedupDedup, ipDedup)
Loop Until myLen = Len(mySource)
Dedup = mySource
End Function
If you have leading or trailing characters you can use a more flexible trim function
Public Function Trimmer(ByVal ipString As String, Optional ByVal ipTrimChars As String = " ,;" & vbCrLf & vbTab) As String
Dim myString As String
myString = ipString
Dim myIndex As Long
For myIndex = 1 To 2
If VBA.Len(myString) = 0 Then Exit For
Do While VBA.InStr(ipTrimChars, VBA.Left$(myString, 1)) > 0
DoEvents ' Always put a do event statement in a do loop
myString = VBA.Mid$(myString, 2)
Loop
myString = VBA.StrReverse(myString)
Next
Trimmer = myString
End Function
Related
I have a column containing formulas as "strings", i.e. "=+I11+I192+I245+I280"
I need to replace the cells (I11, I192,I245andI280`) ID with the content (strings) contained in the cells themselves.
Example:
Cell X --> "=+I11+I192+I245+I280"
Cell I11 = 'A'
Cell I192 = 'B'
Cell I245 = 'C'
Cell I280 = 'D'
The formula should generate "=+A+B+C+D".
This?
="=+" & I11 &"+" & I192 &"+" & I245 & "+" & I280
Well, how about :
=I11 & I192 & I245 & I280
Or you can include spaces
=I11 & " " & I192
But straight quotes - my phone is being funny...
The formula should generate --> "=+A+B+C+D"
Try,
="=+"&textjoin("+", true, I11, I192, I245, I280)
Don't know what you will be doing with empty cells so here is draft
Public Sub test()
[I11] = "A": [I192] = "B": [I245] = "C": [I280] = "D"
Debug.Print ConvertedString("=+I11+I192+I245+I280")
End Sub
Public Function ConvertedString(ByVal inputString As String) As Variant
Dim arr() As String, i As Long
On Error GoTo errHand
If Not InStr(inputString, Chr$(43)) > 0 Then
ConvertedString = CVErr(xlErrNA)
Exit Function
End If
arr = Split(inputString, Chr$(43))
For i = 1 To UBound(arr)
arr(i) = Range(arr(i))
Next i
ConvertedString = Join(arr, Chr$(43))
Exit Function
errHand:
ConvertedString = CVErr(xlErrNA)
End Function
I think you mean something like
=INDIRECT(I11,TRUE)+INDIRECT(I192,TRUE)+INDIRECT(I245,TRUE)+INDIRECT(I280,TRUE)
but please note that Indirect is a volatile function, and can slow your calculations down if used extensively.
Using VBA (with only single delimiter):
Function ReplaceAddr(sInput As String, Optional sDelimiter As String = "+") As String
Dim sArr
Dim i As Long
sArr = Split(sInput, sDelimiter)
For i = 1 To UBound(sArr)
sArr = Range(sArr(i))
Next i
ReplaceAddr = Join(sArr, sDelimiter)
End Function
From OP's comment:
The problem is that formulas changes, so I can't only change manually. The one I gave you is only an example, but I have so many different ones with all math operators.
You can try finding cell addresses with regular expression and replace with cell's value:
Function ReplaceAddr2(sInput As String) As String
Dim oRegEx As Object
Dim oMatches As Object
Dim i As Long, lStart As Long, lLength As Long
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Pattern = "[A-Za-z]{1,3}\d{1,7}"
oRegEx.Global = True
oRegEx.MultiLine = True
Set oMatches = oRegEx.Execute(sInput)
lStart = 0
For i = 0 To oMatches.Count - 1
lLength = oMatches(i).FirstIndex - lStart
ReplaceAddr2 = ReplaceAddr2 & Mid$(sInput, lStart + 1, lLength) & Range(oMatches(i).Value)
lStart = lStart + lLength + oMatches(i).length
Next
ReplaceAddr2 = ReplaceAddr2 & Mid(sInput, lStart + 1, Len(sInput) - lStart)
End Function
Pattern is 1-3 letters followed by 1-7 digits.
Both functions are not volatile - will be recalculated only when input string changes, but not when cells addressed there change. Adding this line:
Application.Volatile True
will make it recalculate on every change, but it may affect performance.
This question already has answers here:
Excel UDF for capturing numbers within characters
(4 answers)
Closed 4 years ago.
I need to extract the numbers from a string of text and I'm not quite sure how to do it. The code I've attached below is very preliminary and most likely can be done more elegantly. A sample of the string I'm trying to parse is as follows:
"ID CSys ID Set ID Set Value Set Title 7026..Plate Top MajorPrn Stress 7027..Plate Top MinorPrn Stress 7033..Plate Top VonMises Stress"
I need to pull the numbers 7026, 7027, and 7033. The string will vary in length and the number of values that I'll need to pull will also vary. Any help would be much appreciated. Thanks!
Dim WrdArray() As String
Dim txtstrm As TextStream
Dim line As String
Dim clm As Long
Dim Rw As Long
'------------------------------------------------------------
Dim i As Long
Dim strPath As String
Dim strLine As String
Dim count, count1 As Integer
Dim holder As String
Dim smallSample As String
count = 0
count1 = 1
holder = ""
'Remove Filters and Add Custom Filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Text Files", "*.txt")
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Dat Files", "*.dat")
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
End If
'------------------------------------------------------------
If strPath <> "" Then
Set txtstrm = FSO.OpenTextFile(strPath)
Else
MsgBox "No file selected.", vbExclamation
Exit Sub
End If
Rw = 1
Do Until txtstrm.AtEndOfStream
line = txtstrm.ReadLine
clm = 1
WrdArray() = Split(line, " ") 'Change with ; if required
For Each wrd In WrdArray()
If Rw = 1 Then
Do While count <> Len(wrd)
smallSample = Left(wrd, 1)
If smallSample = "0" Or smallSample = "1" Or smallSample = "2" Or smallSample = "3" Or smallSample = "4" _
Or smallSample = "5" Or smallSample = "6" Or smallSample = "7" Or smallSample = "8" _
Or smallSample = "9" Then
holder = holder & smallSample
Else
If holder <> "" Then
Cells(count1, 1) = holder
count1 = count1 + 1
End If
holder = ""
End If
wrd = Right(wrd, Len(wrd) - 1)
clm = clm + 4
ActiveSheet.Cells(Rw, clm) = holder
Loop
Else
ActiveSheet.Cells(Rw, clm) = wrd
clm = clm + 1
End If
Next wrd
Rw = Rw + 1
Loop
txtstrm.Close
End Sub
You can use Regular Expressions.
Sub ExtractNumbers()
Dim str As String, regex As regExp, matches As MatchCollection, match As match
str = "ID CSys ID Set ID Set Value Set Title 7026..Plate Top MajorPrn Stress 7027..Plate Top MinorPrn Stress 7033..Plate Top VonMises Stress"
Set regex = New regExp
regex.Pattern = "\d+" '~~~> Look for variable length numbers only
regex.Global = True
If (regex.Test(str) = True) Then
Set matches = regex.Execute(str) '~~~> Execute search
For Each match In matches
Debug.Print match.Value '~~~> Prints: 7026, 7027, 7033
Next
End If
End Sub
Make sure you reference the VBA regex library:
Open VBA editor
Tools > References...
Check Microsoft VBScript Regular Expression 5.5
To exact numbers in the form you want, try something like:
Sub dural()
Dim s As String, i As Long, L As Long, c As String, temp As String
s = [A1]
L = Len(s)
temp = ""
For i = 1 To L
c = Mid(s, i, 1)
If c Like "[0-9]" Then
temp = temp & c
Else
temp = temp & " "
End If
Next i
temp = "'" & Application.WorksheetFunction.Trim(temp)
temp = Replace(temp, " ", ",")
[B1] = temp
End Sub
You can use this function that splits the "words and test for numeric:
Function numfromstring(str As String) As String
Dim strarr() As String
str = Replace(str, ".", " ")
strarr = Split(str)
Dim i As Long
For i = 0 To UBound(strarr)
If IsNumeric(strarr(i)) Then
numfromstring = numfromstring & "," & strarr(i)
End If
Next i
numfromstring = Mid(numfromstring, 2)
End Function
You would call it from the worksheet with a formula:
=numfromstring(A1)
Or from vba like this:
Sub try()
Dim str As String
str = "ID CSys ID Set ID Set Value Set Title 7026..Plate Top MajorPrn Stress 7027..Plate Top MinorPrn Stress 7033..Plate Top VonMises Stress"
Dim out As String
out = numfromstring(str)
Debug.Print out
End Sub
If you have Office 365 Excel you can use this array formula:
=TEXTJOIN(",",TRUE,IF(ISNUMBER(--TRIM(MID(SUBSTITUTE(SUBSTITUTE(A1,"."," ")," ",REPT(" ",99)),(ROW($1:$100)-1)*99+1,99))),TRIM(MID(SUBSTITUTE(SUBSTITUTE(A1,"."," ")," ",REPT(" ",99)),(ROW($1:$100)-1)*99+1,99)),""))
Being an array formula it needs to be confirmed with Ctrl-Shift-Enter instead of Enter when exiting edit mode:
I was wondering how to remove duplicate names/text's in a cell. For example
Jean Donea Jean Doneasee
R.L. Foye R.L. Foyesee
J.E. Zimmer J.E. Zimmersee
R.P. Reed R.P. Reedsee D.E. Munson D.E. Munsonsee
While googling, I stumbled upon a macro/code, it's like:
Function RemoveDupes1(pWorkRng As Range) As String
'Updateby20140924
Dim xValue As String
Dim xChar As String
Dim xOutValue As String
Set xDic = CreateObject("Scripting.Dictionary")
xValue = pWorkRng.Value
For i = 1 To VBA.Len(xValue)
xChar = VBA.Mid(xValue, i, 1)
If xDic.exists(xChar) Then
Else
xDic(xChar) = ""
xOutValue = xOutValue & xChar
End If
Next
RemoveDupes1 = xOutValue
End Function
The macro is working, but it is comparing every letter, and if it finds any repeated letters, it's removing that.
When I use the code over those names, the result is somewhat like this:
Jean Dos
R.L Foyes
J.E Zimers
R.P edsDEMuno
By looking at the result I can make out it is not what I want, yet I got no clue how to correct the code.
The desired output should look like:
Jean Donea
R.L. Foye
J.E. Zimmer
R.P. Reed
Any suggestions?
Thanks in Advance.
Input
With the input on the image:
Result
The Debug.Print output
Regex
A regex can be used dynamically iterating on the cell, to work as a Find tool. So it will extract only the shortest match. \w*( OUTPUT_OF_EXTRACTELEMENT )\w*, e.g.: \w*(Jean)\w*
The Regex's reference must be enabled.
Code
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
On Error GoTo ErrHandler:
EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
Exit Function
ErrHandler:
' error handling code
EXTRACTELEMENT = 0
On Error GoTo 0
End Function
Sub test()
Dim str As String
Dim objMatches As Object
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For Row = 1 To lastrow
str = Range("A" & Row)
F_str = ""
N_Elements = UBound(Split(str, " "))
If N_Elements > 0 Then
For k = 1 To N_Elements + 1
strPattern = "\w*(" & EXTRACTELEMENT(CStr(str), k, " ") & ")\w*"
With objRegExp
.Pattern = strPattern
.Global = True
End With
If objRegExp.test(strPattern) Then
Set objMatches = objRegExp.Execute(str)
If objMatches.Count > 1 Then
If objRegExp.test(F_str) = False Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
ElseIf k <= 2 And objMatches.Count = 1 Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
End If
Next k
Else
F_str = str
End If
Debug.Print Trim(F_str)
Next Row
End Sub
Note that you can Replace the Debug.Print to write on the target
cell, if it is column B to Cells(Row,2)=Trim(F_str)
Explanation
Function
You can use this UDF, that uses the Split Function to obtain the element separated by spaces (" "). So it can get every element to compare on the cell.
Loops
It will loop from 1 to the number of elements k in each cell and from row 1 to lastrow.
Regex
The Regex is used to find the matches on the cell and Join a new string with the shortest element of each match.
This solution operates on the assumption that 'see' (or some other three-letter string) will always be on the end of the cell value. If that isn't the case then this won't work.
Function RemoveDupeInCell(dString As String) As String
Dim x As Long, ct As Long
Dim str As String
'define str as half the length of the cell, minus the right three characters
str = Trim(Left(dString, WorksheetFunction.RoundUp((Len(dString) - 3) / 2, 0)))
'loop through the entire cell and count the number of instances of str
For x = 1 To Len(dString)
If Mid(dString, x, Len(str)) = str Then ct = ct + 1
Next x
'if it's more than one, set to str, otherwise error
If ct > 1 Then
RemoveDupeInCell = str
Else
RemoveDupeInCell = "#N/A"
End If
End Function
In VBA if I have a string of numbers lets say ("1,2,3,4,5,2,2"), how can I remove the duplicate values and only leave the first instance so the string says ("1,2,3,4,5").
Here is a function you can use to dedupe a string as you've described. Note that this won't sort the deduped string, so if yours was something like "4,2,5,1,3,2,2" the result would be "4,2,5,1,3". You didn't specify you needed it sorted, so I didn't include that functionality. Note that the function uses , as the default delimiter if not specified, but you can specify a delimiter if you choose.
Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String
Dim varSection As Variant
Dim sTemp As String
For Each varSection In Split(sInput, sDelimiter)
If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
sTemp = sTemp & sDelimiter & varSection
End If
Next varSection
DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)
End Function
Here's some examples of how you would call it:
Sub tgr()
MsgBox DeDupeString("1,2,3,4,5,2,2") '--> "1,2,3,4,5"
Dim myString As String
myString = DeDupeString("4-2-5-1-3-2-2", "-")
MsgBox myString '--> "4-2-5-1-3"
End Sub
I suggest writing a Join function to combine the unique parts back into a single string (there is one available for arrays, but not for any other collection):
Function Join(Iterable As Variant, Optional Delimiter As String = ",") As String
Dim notFirst As Boolean
Dim item As Variant
For Each item In Iterable
If notFirst Then
Join = Join & Delimiter
Else
notFirst = True
End If
Join = Join & item
Next
End Function
Then, use Split to split a string into an array, and Scripting.Dictionary to enforce uniqueness:
Function RemoveDuplicates(s As String, Optional delimiter As String = ",") As String
Dim parts As String()
parts = Split(s,delimiter)
Dim dict As New Scripting.Dictionary
Dim part As Variant
For Each part In parts
dict(part) = 1 'doesn't matter which value we're putting in here
Next
RemoveDuplicates = Join(dict.Keys, delimiter)
End Function
try this:
Sub test()
Dim S$: S = "1,2,3,4,5,2,2,5,6,6,6"
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim Key As Variant
For Each Key In Split(S, ",")
If Not Dic.exists(Trim(Key)) Then Dic.Add Trim(Key), Nothing
Next Key
S = Join(Dic.Keys, ","): MsgBox S
End Sub
Heres my crack at it:
Function Dedupe(MyString As String, MyDelimiter As String)
Dim MyArr As Variant, MyNewArr() As String, X As Long, Y As Long
MyArr = Split(MyString, MyDelimiter)
ReDim MyNewArr(0)
MyNewArr(0) = MyArr(0)
Y = 0
For X = 1 To UBound(MyArr)
If InStr(1, Join(MyNewArr, MyDelimiter), MyDelimiter & MyArr(X)) = 0 Then
Y = Y + 1
ReDim Preserve MyNewArr(Y)
MyNewArr(Y) = MyArr(X)
End If
Next
Dedupe = Join(MyNewArr, MyDelimiter)
End Function
Call it like this in code:
Dedupe(Range("A1").Text,",")
Or like this in the sheet:
=Dedupe(A1,",")
The first parameter is the cell to test and the second is the delimiter you want to use (in your example it is the comma)
vb6,Find Duplicate letter in word when there is no delimiter.
Function RemoveDuplicateLetter(ByVal MyString As String) As String
Dim MyArr As Variant, MyNewArr() As String, X As String,str as String
Dim bValue As Boolean
Dim i As Long, j As Long
For i = 0 To Len(MyString)
str = str & Mid$(MyString, i + 1, 1) & vbNullChar
Next
i = 0
MyArr = Split(str, vbNullChar)
ReDim MyNewArr(0)
MyNewArr(0) = MyArr(0)
For i = LBound(MyArr) To UBound(MyArr)
bValue = True
For j = i + 1 To UBound(MyArr)
If MyArr(i) = MyArr(j) Then
bValue = False
Exit For
End If
Next
If bValue Then X = X & " " & MyArr(i)
Next
RemoveDuplicateLetter = X
End Function
How do I remove special characters and alphabets in a string ?
qwert1234*90)! ' this might be my cell value
I have to convert it to
123490 ' I mean I have to remove everything but keep only the numbers in string
but it should allow spaces !
qwe123 4567*. 90 ' String with spaces
123 4567 90 ' output should be
I found the vba Replace - but writing a replace for each character makes my code big. Well let me tell you clearly without hiding anything from you:
input: qwe123 4567*. 90 ' String with spaces cells(1,"A").value
My idea to do these next: 123 4567 90 ' remove characters first keeping white spaces
final output in A1:A3
123
4567
90
(for every space it should insert row and fill that)
Could you tell me how do remove all characters except numbers and spaces in string?
Thanks In advance
You need to use a regular expression.
See this example:
Option Explicit
Sub Test()
Const strTest As String = "qwerty123 456 uiops"
MsgBox RE6(strTest)
End Sub
Function RE6(strData As String) As String
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = True
.IgnoreCase = True
.Pattern = "([0-9]| )+"
End With
Set REMatches = RE.Execute(strData)
RE6 = REMatches(0)
End Function
Explanation:
Pattern = "([0-9]| )+" will match any 0 or more group (+) containing a number ([0-9]) or (|) a space ().
Some more info on the regexp:
a thread on ozgrid
a very good reference about regexp
Non-re alternative;
Public Function fmt(sValue As String) As String
Dim i As Long
For i = 1 To Len(sValue) '//loop each char
Select Case Mid$(sValue, i, 1) '//examine current char
Case "0" To "9", " " '//permitted chars
'//ok
Case Else
Mid$(sValue, i, 1) = "!" '//overwrite char in-place with "!"
End Select
Next
fmt = Replace$(sValue, "!", "") '//strip invalids & return
End Function
For:
?fmt("qwe123 4567*. 90")
123 4567 90
Those two funny codes will do both of your whishes..
Sub MySplitter(strInput As String)
Row = 10 ' Start row
Col = "A" ' Column Letter
Range(Col & Row) = "" ' Clean the start cell
For i = 1 To Len(strInput) ' Do with each Character in input string...
c = Mid(strInput, i, 1) ' Get actual char
If IsNumeric(c) Then Range(Col & Row) = Range(Col & Row) & c ' If numeric then append to actual cell
If (c = " ") And (Range(Col & Row) <> "") Then 'If space and actual row is not empty then...
Row = Row + 1 ' Jump to next row
Range(Col & Row) = "" ' Clean the new cell
End If
Next
End Sub
Function KeepNumbersAndSpaces(ByVal strInput As String)
For i = 1 To Len(strInput) ' Do with each Character in input string...
c = Mid(strInput, i, 1) ' Get actual char
If IsNumeric(c) Or c = " " Then ' If numeric or a space then append to output
KeepNumbersAndSpaces = KeepNumbersAndSpaces & c
End If
Next
End Function
Sub Test()
strInput = "qwert1234*90)! qwe123 4567*. 90"
MySplitter (strInput)
Range("A5") = KeepNumbersAndSpaces(strInput)
End Sub
Something like this to
split the string using a regexp
place the matches into an array
dump the array to an automatically sized spreadsheet range
main sub
Sub CleanStr()
Dim strOut As String
Dim Arr
strOut = Trim(KillChar("qwe123 4567*. 90 "))
Arr = Split(strOut, Chr(32))
[a1].Resize(UBound(Arr) + 1, 1) = Application.Transpose(Arr)
End Sub
function
Function KillChar(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\d\s]+"
KillChar = .Replace(strIn, vbNullString)
End With
End Function