For example, I have this string that reads "IRS150Sup2500Vup". It could also be "IRS250Sdown1250Vdown".
I am looking to extract the number between the two S. Hence for the first case, it will be 150 and second case, it is 250. The numbers are not always 3 digits. It could vary.
What I have tried:
Dim pos As Integer
Dim pos1 As Integer
pos = InStr("IRS150Sup2500Vup", "S")
pos1 = InStrRev("IRS250Sdown1250Vdown","S")
After this, I am stuck how to get the number out.
Need some guidance on how to do this.
As i suggested here, the simplest way is to use Regex.
Sub Test()
Dim r As VBScript_RegExp_55.RegExp
Dim sPattern As String, myString As String
Dim mc As VBScript_RegExp_55.MatchCollection, m As VBScript_RegExp_55.Match
myString = "IRS150Sup2500Vup"
sPattern = "\d+" 'searches for numbers
Set r = New VBScript_RegExp_55.RegExp
r.Pattern = sPattern
Set mc = r.Execute(myString)
For Each m In mc ' Iterate Matches collection.
MsgBox "number: '" & m.Value & "' founded at: " & m.FirstIndex & " length: " & m.Length
Next
End Sub
Here is an option:
Public Sub Test4()
Dim pos As Integer
Dim pos1 As Integer
Dim strOrig As String
Dim strString As String
strOrig = "IRS150Sup2500Vup"
pos = InStr(1, strOrig, "S") + 1
pos1 = InStr(pos, strOrig, "S")
strString = Mid(strOrig, pos, pos1 - pos)
MsgBox strString
End Sub
Try using this function:
pos = Mid("IRS150Sup2500Vup", 4, 6)
Related
I'm pretty new to VBA. So I have a string with a bunch of random words in it like this:
"foo Foo FOO Bar FoO Faz FAZ"
How do I find the number of unique words in the string? In the above example, it would be simply 3, as there's only foo, bar, and faz. I have some code here but it outputs the wrong value, I'm not sure if I should be adding it to an array or some sort of database instead and then iterate through the database to check for duplicates.
Function UniqueWordCount(TextString As String) As Integer
TextString = LCase(TextString)
Dim Result() As String
Dim Count As Integer
Result = Split(TextString, " ")
Count = UBound(Result()) + 1
Dim k As Integer
Dim repeat As Integer
repeat = 0
For i = LBound(Result) To UBound(Result)
For k = 0 To i
If Result(i) = Result(k) Then
repeat = repeat + 1
End If
Next k
Next i
If repeat > 1 Then
repeat = repeat - 1
End If
repeat = repeat - i
UniqueWordCount = Count - repeat
End Function
Count Unique Words in a Sentence
Be careful with this simple Regex pattern, it may not work as expected.
Uncomment the Debug.Print lines to get a better feel of what is happening.
Option Explicit
Sub UniqueWordsCountTEST()
Dim Sentence As String
Sentence = "I am using this Regex to get rid off the punctuation,?!:;-. " _
& "I am using a dictionary to get rid off duplicates, and the " _
& "dictionary's CompareMode for 'word' to be the same as 'WORD'."
' 12 Dupes: I,am,using,to,get,rid,off,the,dictionary,to,the,WORD
Debug.Print "Unique Words Count = " & UniqueWordsCount(Sentence)
End Sub
Function UniqueWordsCount( _
ByVal Sentence As String) _
As Long
Dim Matches As Variant
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\w+"
Set Matches = .Execute(Sentence)
'Debug.Print "All Words Count = " & Matches.Count
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Match As Variant
For Each Match In Matches
.Item(Match.Value) = Empty
'Debug.Print "All Words: " & Match.Value
Next Match
UniqueWordsCount = .Count
'Debug.Print "Unique Words:" & vbLf & Join(.Keys, vbLf)
End With
End Function
Use a Scripting.Dictionary (add a reference to Microsoft Scripting Runtime):
Sub foo()
Dim d As Scripting.Dictionary
Set d = New Scripting.Dictionary
Dim s As String
s = "foo Foo FOO Bar FoO Faz FAZ"
Dim x As Variant
x = Split(s)
Dim i As Long
For i = LBound(x) To UBound(x)
If Not d.Exists(UCase$(x(i))) Then
d.Add UCase$(x(i)), "whatever"
End If
Next
Debug.Print d.Count ' returns 3
End Sub
Or even simpler:
For i = LBound(x) To UBound(x)
d(UCase$(x(i))) = "whatever"
Next
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
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.
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