I have a cell value like this:
This is a <"string">string, It should be <"changed">changed to <"a"> a number.
There are some words repeated in this part <" ">.
I want use Excel VBA to change the cell value to:
This is a string, It should be changed to a number.
Any help will be appreciated. Thanks.
Following up on the suggestion to use regular expressions, here's an example:
Option Explicit
Sub RemoveByRegexWithLateBinding()
Dim strIn As String
Dim strOut As String
Dim objRegex As Object
'input
strIn = "This is a <""string"">string, It should be <""changed"">changed to <""a""> a number."
Debug.Print "Input:" & vbCr & strIn
'create and apply regex
Set objRegex = CreateObject("VBScript.RegExp")
objRegex.Pattern = "<""[^<>""]*"">"
objRegex.Global = True
strOut = objRegex.Replace(strIn, "")
'test output
Debug.Print "Output:" & vbCr & strOut
End Sub
Produces this output:
Input:
This is a <"string">string, It should be <"changed">changed to <"a"> a number.
Output:
This is a string, It should be changed to a number.
Diagram of regular expression:
Which can be explained as finding a string that:
begins with <"
contains anything apart from the characters <, > and "
ends with ">
Assuming the text in cell A1, then try this code
Sub DelDoubleString()
Dim Text As String, Text2Replace As String, NewText As String
On Error Resume Next 'Optional, in case there's no double string to be deleted
Text = Cells(1, 1)
Do
Text2Replace = Mid$(Text, InStr(Text, "<"), InStr(Text, ">") - InStr(Text, "<") + 1)
NewText = Application.WorksheetFunction.Substitute(Text, Text2Replace, vbNullString)
Text = NewText
Loop Until InStr(NewText, "<") = 0
Cells(1, 1) = NewText
End Sub
Select the cells containing your text and run this short macro:
Sub Kleanup()
Dim d As Range, s As String, rng As Range
Dim gather As Boolean, L As Long, DQ As String
Dim i As Long, s2 As String, CH As String
Set rng = Selection
DQ = Chr(34)
For Each r In rng
s = Replace(r.Text, "<" & DQ, Chr(1))
s = Replace(s, DQ & ">", Chr(2))
gather = True
L = Len(s)
s2 = ""
For i = 1 To L
CH = Mid(s, i, 1)
If CH = Chr(1) Then gather = False
If CH = Chr(2) Then gather = True
If gather And CH <> Chr(2) Then s2 = s2 & CH
Next i
r.Value = s2
Next r
End Sub
U can Use Replace function
ActiveSheet.Cells(1, 1).Value = Replace(ActiveSheet.Cells(1, 1).Value, "String", "Number")
Related
I am looking to search for values from a list in Sheet1 in each cell of column C on sheet2 to be separated by commas.
Sheet1 has a list of names:
Sheet 2 has a set of sentences in column C. The output in column D should be the names in Sheet1.
I have searched but haven't found a solution.
I don't have any code to show that has been effective in this regard but I did come across a function that seemed promising but, since I don't know what would surround the name per cell it isn't quite what I need.
Function RegexExtract(ByVal text As String, _
ByVal extract_what As String, _
Optional separator As String = ", ") As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
Dim i As Long, j As Long
Dim result As String
RE.Pattern = extract_what
RE.Global = True
Set allMatches = RE.Execute(text)
For i = 0 To allMatches.Count - 1
For j = 0 To allMatches.Item(i).submatches.Count - 1
result = result & (separator & allMatches.Item(i).submatches.Item(j))
Next
Next
If Len(result) <> 0 Then
result = Right$(result, Len(result) - Len(separator))
End If
RegexExtract = result
End Function
Using regexp Test:
Function CheckList(ByVal text As String, list As Range) As String
Static RE As Object
Dim arr, sep, r As Long, result As String, v
If RE Is Nothing Then Set RE = CreateObject("vbscript.regexp")
If Len(text) > 0 Then
arr = list.Value
'check each name
For r = 1 To UBound(arr, 1)
v = arr(r, 1)
If Len(v) > 0 Then
RE.Pattern = "\b" & v & "\b" '<< whole word only
If RE.test(text) Then
result = result & sep & v
sep = ", " 'populate the separator
End If
End If
Next r
End If
CheckList = result
End Function
You can use a Dictionary object to check each string against the NameList, assuming that the names in the sample string do not have punctuation.
If they do, this method can still be used, but would require some modification. For example, one could replace all of the punctuation with spaces; or do something else depending on how complex things might be.
eg:
Option Explicit
Function ckNameList(str As String, nameList As Range) As String
Dim D As Dictionary
Dim vNames, I As Long, V, W
Dim sOut As String
vNames = nameList
Set D = CreateObject("Scripting.Dictionary")
D.CompareMode = TextCompare
For I = 1 To UBound(vNames)
If Not D.Exists(vNames(I, 1)) Then _
D.Add vNames(I, 1), vNames(I, 1)
Next I
V = Split(str, " ")
sOut = ""
For Each W In V
If D.Exists(W) Then _
sOut = sOut & ", " & W
Next W
ckNameList = Mid(sOut, 3)
End Function
Scott showed how to use TEXTJOIN, when you don't have access to this function. Your best best might be VBA. We could emulate some sort of TEXTJOIN, possibly like so:
Function ExtractNames(nms As Range, str As Range) As String
ExtractNames = Join(Filter(Evaluate("TRANSPOSE(IF(ISNUMBER(SEARCH(" & nms.Address & "," & str.Address & "))," & nms.Address & ",""|""))"), "|", False), ", ")
End Function
Called in D2 like: =ExtractNames($A$2:$A$7,C2) and dragged down. Downside of this Evalate method is that it's making use of an array formula, however the native TEXTJOIN would have been so too. Plusside is that it's avoiding iteration.
EDIT
As #TimWilliams correctly stated, this might end up confusing substrings that hold part of what we are looking for, e.g. > Paul in Pauline.
I also realized that to overcome this, we need to substitute special characters. I've rewritten my function to the below:
Function ExtractNames(nms As Range, str As Range) As String
Dim chr() As Variant, arr As Variant
'Create an array of characters to ignore
chr = Array("!", ",", ".", "?")
'Get initial array of all characters, with specified characters in chr substituted for pipe symbol
arr = Evaluate("TRANSPOSE(IF(ISNUMBER(MATCH(MID(" & str.Address & ",ROW(A1:A" & Len(str.Value) & "),1),{""" & Join(chr, """,""") & """},0)),""|"",MID(" & str.Address & ",ROW(A1:A" & Len(str.Value) & "),1)))")
'Get array of words used to check against names without any specified characters
arr = Split(Join(Filter(arr, "|", False), ""), " ")
'Check which names occur in arr
For Each cl In nms
If IsNumeric(Application.Match(cl.Value, arr, 0)) Then
If ExtractNames = "" Then
ExtractNames = cl.Value
Else
ExtractNames = Join(Array(ExtractNames, cl.Value), ", ")
End If
End If
Next cl
End Function
As you can tell, it's possible still, but my conclusion and recommendation would be to go with RegEx. #TimWilliams has a great answer explaining this, which I slightly adapted to prevent an extra iteration:
Function ExtractNames(nms As Range, str As Range) As String
Dim regex As Object: Set regex = CreateObject("VBScript.RegExp")
Dim arr() As Variant: arr = Application.Transpose(nms.Value)
Dim del As String
regex.Pattern = "\b(?:" & Join(arr, "|") & ")\b"
regex.Global = True
regex.Ignorecase = True
Set hits = regex.Execute(str.Value)
For Each hit In hits
ExtractNames = ExtractNames & del & hit
del = ", "
Next hit
End Function
Or even without iteration:
Function ExtractNames(nms As Range, str As Range) As String
Dim regex As Object: Set regex = CreateObject("VBScript.RegExp")
Dim arr() As Variant: arr = Application.Transpose(nms.Value)
Dim del As String
regex.Global = True
regex.Ignorecase = True
'Perform 1st replace on non-alphanumeric characters
regex.Pattern = "[^\w]"
ExtractNames = Application.Trim(regex.Replace(str.Value, " "))
'Perferom 2nd replace on all words that are not in arr
regex.Pattern = "\b(?!" & Join(arr, "|") & ")[\w-]+\b"
ExtractNames = Application.Trim(regex.Replace(ExtractNames, " "))
ExtractNames = Replace(ExtractNames, " ", ", ")
End Function
Is there a way to compare a large string of text with another large string of text in another cell and get percentage string match ignoring case sensativity.
For example:
Cell a1: Please support this application inquiry
Cell b2: Please support another application process
do comparison of both cells and return percentage match: %60 match with possibility of highlighting.
Thanks
I tried column match.
Function CompareString(rngS1 As Range, rngS2 As Range, strType As String, Optional boolCase As Boolean = True) As Variant
Dim vW1, vW2
Dim oDic As Object
Dim lngW As Long, lngU As Long, lngM As Long, lngTemp As Long, rngCell As Range
Dim strTemp As String, strC As String, strB As String
vW2 = Split(Application.WorksheetFunction.Trim(Replace(Replace(rngS2.Text, ".", ""), Chr(100), " ")), " ")
Set oDic = CreateObject("Scripting.Dictionary")
For lngW = LBound(vW2) To UBound(vW2) Step 1
strTemp = vW2(lngW)
With oDic
If Not .exists(strTemp) Then
lngU = lngU + 1
.Add strTemp, lngU
End If
End With
Next lngW
Set oDic = Nothing
For Each rngCell In rngS1.Cells
strC = Application.WorksheetFunction.Trim(Replace(Replace(rngCell.Text, ".", ""), Chr(100), " "))
If strC <> "" Then
If strC = rngS2.Text Then
lngM = lngU
strB = rngS2.Text
Else
vW1 = Split(strC, " ")
lngTemp = 0
For lngW = LBound(vW2) To UBound(vW2) Step 1
strTemp = vW2(lngW)
If boolCase Then
lngTemp = lngTemp + rngS1.Parent.Evaluate("SUMPRODUCT(--ISNUMBER(FIND("" " & strTemp & " "","" " & strC & " "")))")
Else
lngTemp = lngTemp - IsNumeric(Application.Match(strTemp, vW1, 0))
End If
Next lngW
If lngTemp > lngM Then
lngM = lngTemp
strB = rngCell.Text
End If
End If
End If
Next rngCell
Select Case UCase(strType)
Case "P"
CompareString = lngM / lngU
Case "S"
CompareString = strB
End Select
End Function
This is pretty simple but should give you what you're looking for. It splits the strings in the cells up based on spaces and should return the overlap of words within them as a percent.
Sub test()
MsgBox 100 * CompareTwoStrings(Range("A1").Value2, Range("B2").Value2)
End Sub
Function CompareTwoStrings(ByVal str1 As String, ByVal str2 As String) As Double
str1 = ReplaceSpecialChars(str1)
str2 = ReplaceSpecialChars(str2)
Dim splitStrShorter As Variant
Dim splitStrLonger As Variant
If (Len(str1) - Len(Replace(str1, " ", ""))) > (Len(str2) - Len(Replace(str2, " ", ""))) Then
splitStrLonger = Split(LCase(str1), " ")
splitStrShorter = Split(LCase(str2), " ")
Else
splitStrLonger = Split(LCase(str2), " ")
splitStrShorter = Split(LCase(str1), " ")
End If
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 0 To UBound(splitStrLonger)
If Not dict.exists(splitStrLonger(i)) Then
dict.Add splitStrLonger(i), ""
End If
Next i
Dim frequency As Long
For i = 0 To UBound(splitStrShorter)
If dict.exists(splitStrShorter(i)) Then
frequency = frequency + 1
End If
Next i
CompareTwoStrings = frequency / (UBound(splitStrLonger) + 1)
End Function
Function ReplaceSpecialChars(ByVal strToReplace As String) As String
Dim specialChars As String
specialChars = "`,-,=,!,#,#,$,%,^,&,*,(,),_,+,[,],\,{,},|,;,',:," & Chr(34) & ",.,/,<,>,?"
Dim char As Variant
For Each char In Split(specialChars, ",")
strToReplace = Replace(strToReplace, char, "")
Next
ReplaceSpecialChars = strToReplace
End Function
See the title. Here is my code:
Option Explicit
Sub MakeWordList()
Dim mObjWord As Word.Application
Dim InputSheet As Worksheet
Dim WordListSheet As Worksheet
Dim PuncChars As Variant, x As Variant
Dim i As Long, r As Long
Dim txt As String
Dim wordCnt As Long
Dim AllWords As Range
Dim oString As String
Set mObjWord = CreateObject("Word.Application")
Application.ScreenUpdating = True
Set InputSheet = ActiveSheet
Set WordListSheet = Worksheets.Add(After:=Worksheets(Sheets.Count))
WordListSheet.Range("A1") = "All Words"
WordListSheet.Range("A1").Font.Bold = True
InputSheet.Activate
wordCnt = 2
PuncChars = Array(".", ",", ";", ":", "'", "!", "#", _
"$", "%", "&", "(", ")", " - ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*")
r = 1
oString = ""
'Loop until blank cell is encountered and add the word to oString
Do While Cells(r, 1) <> ""
txt = Cells(r, 1)
For i = 0 To UBound(PuncChars)
txt = Replace(txt, PuncChars(i), "")
Next i
'Remove excess spaces
txt = WorksheetFunction.Trim(txt)
'Extract the words
x = Split(txt)
For i = 0 To UBound(x)
Set mObjWord = CreateObject("Word.Application")
' it does not run from here
Select Case x(i)
Case wdAdverb, wdVerb, wdConjunction, wdIdiom, wdInterjection, wdPronoun, wdPreposition
Case Else
oString = oString & " " & x(i)
End Select
Next i
InputSheet.Range("r, 2").Value = oString
r = r + 1
Loop
End Sub
It seems that you wish to load an instance of MS Word (actually, your code loads many in a loop, possibly hundreds) to access the enumerations like wdVerb which you hope will identify verbs in the text. Enumerations are numbers, long integers to be precise. For example, wdVerb represents the value 3 (Type ? wdVerb in the Immediate window of Word VBE).
I have no idea what Word does with these numbers, but your x(i) holds a string.
Select Case x(i)
Case wdAdverb, wdVerb
Case Else
must therefore always default to Else unless it's a 2 or 3 or one of the other numbers you list there.
The first question which comes to my mind is why you don't use Word. Use a Word table in a Word document.
Secondly, your idea can't be made to work. Identifying the verb in "Did I go?" or "I am the go-between" is a big job. Don't expect it to be performed by Word at the drop of a number.
Thirdly, it seems that you wish to extract most words. Why not extract all words first and then make a list of word you want excluded and filter them out.
Finally, your Array(".", ",", ";") seems complicated. The following structure is less voluminous?
PuncChars = ".,;"
and
For i = 1 to Len(PuncChars)
Txt = Replace(Txt, Mid(PuncChars, i, 1), "")
Next i
You would be able to use a very similar system to filter out the words you don't want extracted.
here is the new code now:
Option Explicit
Sub MakeWordList()
Dim mObjWord As Word.Application
Dim mySynInfo As Word.SynonymInfo
Dim InputSheet As Worksheet
Dim PuncChars As Variant, x As Variant
Dim i As Long, r As Long, j As Long
Dim txt As String
Dim oString As String
Dim myList As Variant
Dim myPos As Variant
Dim skipWord As Boolean
Set mObjWord = CreateObject("Word.Application")
Application.ScreenUpdating = True
Set InputSheet = ActiveSheet
InputSheet.Activate
PuncChars = Array(".", ",", ";", ":", "'", "!", "#", _
"$", "%", "&", "(", ")", " - ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*")
r = 1
oString = ""
'Loop until blank cell is encountered and add the word to oString
Do While Cells(r, 1) <> ""
txt = Cells(r, 1)
For i = 0 To UBound(PuncChars)
txt = Replace(txt, PuncChars(i), "")
Next i
'Remove excess spaces
txt = WorksheetFunction.Trim(txt)
'Extract the words
x = Split(txt)
For i = 0 To UBound(x)
' getting insufficient memory error at the following command after have
' completed a few iteratons of the For loop successfully
Set mySynInfo = SynonymInfo(Word:=x(i), LanguageID:=wdEnglishUS)
If mySynInfo.MeaningCount <> 0 Then
myList = mySynInfo.MeaningList
myPos = mySynInfo.PartOfSpeechList
For j = 1 To UBound(myPos)
Select Case myPos(j)
Case wdAdverb, wdVerb, wdConjunction, wdIdiom, wdInterjection, wdPronoun, wdPreposition
skipWord = True
Case Else
skipWord = False
End Select
Next j
If Not skipWord Then
oString = oString & " " & x(i)
End If
End If
Next i
InputSheet.Cells(r, 2).Value = oString
r = r + 1
Loop
End Sub
My Excel cells have carriage return(s) \ line feeds, but when reading into cell.value, the carriage returns disappear. Is there a way to handle this so that I can determine where the line breaks were (without modifying my source Excel sheet data)?
In the code below (at the bottom of this thread), I would have expected the ProductText variable to be set as:
Orange<CR>
Red<CR>
Yellow<CR>
where <cr> means carriage return.
I can confirm that the line-feeds are present when I copy from an Excel cell into Notepad.
But in VBA, ProductText is populated as: "Orange Red Yellow" and the carriage returns are gone.
'YOU MAY SKIP TO THE ******************************************* for the purposes of this post
Public Sub ProcessCharmMingFile(Excel_UNC_Path As String)
Dim src As Workbook
Dim ProdPushWorkbook As Workbook
Set ProdPushWorkbook = ActiveWorkbook
Set src = Workbooks.Open(Excel_UNC_Path, True, True)
Dim c As Range
Dim r As Range
Dim LastRow As Long
Dim Text As String
src.Sheets("Table 1").Activate
src.ActiveSheet.Range("A1").Select
LastRow = src.ActiveSheet.Range("A30000").End(xlUp).Row
Text = LastRow
Text = "A1:T" + CStr(Text)
Set r = Range(Text)
Dim i As Integer
For i = 1 To MaxItems
PONumber(i) = ""
Next
Dim PageCounter As Integer
PageCounter = 0
RecordCounter = 0
Dim ProductText As String
Dim QtyText As String
Dim HeatText As String
'***********************************************************
'***********************************************************
'***********************************************************
For Each c In r
If c.Value = "ALLIED FITTING Product Code" Then
PageCounter = PageCounter + 1
ProductText = c.Offset(1, 0).Value
HeatText = c.Offset(1, 1).Value
QtyText = c.Offset(1, 2).Value
End If
Next
'***********************************************************
'***********************************************************
'***********************************************************
If RecordCounter = 0 Then
Call AbortFileProcessing("No Valid Reoords Dected", False, ProdPushWorkbook)
End If
src.Close
End Sub
The thing is that you need a Line Feed to get the lines to display separately in a cell.
VBA has the appropriate constants for this:
Sub CRLFString()
Dim str As String
str = "hello" & vbCr & "world!"
Range("A1").Value = str 'Reads: "helloworld!" - Wrap Text won't change this.
str = "hello" & vbLf & "world!"
Range("A2").Value = str
str = "hello" & vbCrLf & "world!"
Range("A3").Value = str 'Both of these read
'hello
'world!
End Sub
However, if you would output these strings using Debug.Print all three of them would be on 2 lines as expected.
In short: Add a line feed, otherwise you get the result described in the question.
You can just use Replace on vbCr to do so:
Sub AddLineBreaksAndOutput(str As String)
str = Replace(str, vbCr, vbCrLf)
Range("A4").Value = str
End Sub
Sub Test()
Dim str As String
str = "hello" & vbCr & "world!"
AddLineBreaksAndOutput str
End Sub
Carriage Return Trouble
Out of curiosity what is the code number of the "CR" character. You can get it using this formula: =CODE(MID(A1,7,1)) in Excel (adjust A1 and 7 appropriately).
If this behavior persists you can split the string into an array and concatenate with the appropriate character e.g. Chr(10):
Declare two variables, then after the line ProductText = ... you know what to do.
Dim j As Integer
Dim vntText As Variant
ProductText = c.Offset(1, 0).Value
vntText = Split(ProductText, " ")
For j = 0 To UBound(vntText)
If j > 0 Then
ProductText = ProductText & Chr(10) & vntText(j)
Else
ProductText = vntText(0)
End If
Next
I want to enhance the answer already posted....
You should replace all types of LF's and CR's with vbCRLF, then use that as your splitter.
Here is my code... it can be enhanced further, based on your needs. In my case, it was vbLF that was the culprit, not vbCR. I replaced both, though, with vbCrLF, and then used that as my splitter...
ProductText = Replace(Replace(c.Offset(1, 0).Value, vbCr, vbCrLf), vbLf, vbCrLf)
ProdAry = Split(ProductText, vbCrLf)
I have a text field that I need to extract certain numbers from. The number will always be 7 digits long but the location within the string is not known and how many are in the string is also not known.
A sample string is "SF WO 1564892 DUE 5/19 FIN WO 1638964 DUE 5/27". I want to be able to extract 1564892 and 1638964 and have it generate a new string like "1564892;1638964" and continue to add ";number" if there are more in the string. I use the new string to find and return the largest of these numbers.
I found this and it kind of works but it will also return "1234567" from the string "123456789" which is undesired.
Public Function ExtractDigits(Alphanumeric As String, DigitLength As Long)
Dim StringLenght As Long
Dim CurrentCharacter As String
Dim NewString As String
Dim NumberCounter As Long
Dim TempString As String
StringLenght = Len(Alphanumeric)
For r = 1 To StringLenght
CurrentCharacter = Mid(Alphanumeric, r, 1)
If IsNumeric(CurrentCharacter) Then
NumberCounter = NumberCounter + 1
TempString = TempString & CurrentCharacter
If NumberCounter = DigitLength Then
If NewString = "" Then
NewString = TempString
Else
NewString = NewString & ";" & TempString
End If
End If
End If
If Not IsNumeric(CurrentCharacter) Then
NumberCounter = 0
TempString = ""
End If
Next
ExtractDigits = NewString
End Function
I would prefer the solution be in VBA and not a function but I am open to anything.
What you want can be achieved using RegEx but since I am stepping out so here is a very simple alternative :)
Sub Sample()
Dim s As String
Dim MyAr As Variant
Dim i as Long
s = "Thisis a Sample1234567-Blah12341234\1384156 Blah Blah 1375188 and more Blah 20 Section 1"
For i = Len(s) To 1 Step -1
Select Case Asc(Mid(s, i, 1))
Case 48 To 57
Case Else
s = Replace(s, Mid(s, i, 1), "a")
End Select
Next i
Do While InStr(1, s, "aa")
s = Replace(s, "aa", "a")
Loop
MyAr = Split(s, "a")
For i = LBound(MyAr) To UBound(MyAr)
If Len(Trim(MyAr(i))) = 7 Then Debug.Print MyAr(i)
Next i
'
' This will Give you 1234567, 1384156 and 1375188
'
End Sub
Edit
Logic
Replace anything in that string which is not a number with any alphabet
Replace double instancs of that alphabet till only one remains
Split on that alphabet
Loop and check for the length.
I have displayed those numbers. You can join them
I faced such thing in the past, and hope this approach will help.
Function Extract7Digits(s As String) As String
Dim i As Long
Dim SevenDigits As String
Dim s2 As String
s2 = Replace(s, " ", "|")
i = 1
While i < Len(s2) - 7
If IsNumeric(Mid(s2, i, 7)) Then
SevenDigits = SevenDigits & Mid(s2, i, 7) & ";"
i=i+6
End If
i = i + 1
Wend
Extract7Digits = SevenDigits
End Function
Best.
You can use Regex which is much easier than looping over the whole string.
The regex being used is \b\d{7}\b which means 7 digits delimited by word boundary.
Public Function ExtractDigits(Alphanumeric As String, DigitLength As Long) As String
Dim regEx As Object, matches As Object
Dim i As Long
Dim output As String
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.pattern = "\b\d{" & DigitLength & "}\b"
End With
Set matches = regEx.Execute(Alphanumeric)
For i = 0 To matches.Count - 1
output = output & matches(i) & ";"
Next
If Len(output) > 0 Then output = Left(output, Len(output) - 1)
ExtractDigits = output
End Function
Can your problem be solved by adding an additional If-statement that tests whether the character after the 7th number is a number as well and ignore the number if that is the case?
Public Function ExtractDigits(Alphanumeric As String, DigitLength As Long)
Dim StringLenght As Long
Dim CurrentCharacter As String
Dim NewString As String
Dim NumberCounter As Long
Dim TempString As String
Dim r As Integer
StringLenght = Len(Alphanumeric)
For r = 1 To StringLenght
CurrentCharacter = Mid(Alphanumeric, r, 1)
If IsNumeric(CurrentCharacter) Then
NumberCounter = NumberCounter + 1
TempString = TempString & CurrentCharacter
If NumberCounter = DigitLength Then
If (Not IsNumeric(Mid(Alphanumeric, r + 1, 1))) Then
If NewString = "" Then
NewString = TempString
Else
NewString = NewString & ";" & TempString
End If
End If
End If
End If
If Not IsNumeric(CurrentCharacter) Then
NumberCounter = 0
TempString = ""
End If
Next
ExtractDigits = NewString
End Function