How to parse part of a cell containing x.x.x. and copy the data to another cell? - excel

Question

I have an excel file I want to parse the beginning of each cell in column D and copy and paste the numbers in cell(same row,column B) How do I parse the cells with numbers 0 through 9 and "." and copy just that value x.x.x.x to column B? There is no standard format of how many numbers and periods at the start of the cell in column D. It could be 1.3.4 or 1.3.4. or 1.3 ect...
=====================================================================
'DIMENSIONING VARS AND PATHS
Dim Level As Range
Dim i, j, q(1 To 50) As Long
Dim numofchar As Long
Dim filepath As String
Dim filename As String
Dim PN As String
Dim HEADERrowcallout As Long
Dim LASTREQrowcallout As Long
Dim REQTEXTcolumncallout As String
Dim x As Long
Dim s As String
Dim count As Long
Dim Reqtext As Variant
Dim SectionText As Variant
'
'scanf(Input the correct row and column numbers). Used for determining start and endpoints of filtering files
HEADERrowcallout = InputBox("What row number are your headers in?")
LASTREQrowcallout = InputBox("What row number are your headers in?")
REQTEXTcolumncallout = InputBox("What is the column letter where ReqText is located? (A=1,B=2,D=4,ect...)")
'REQTYPEcolumncallout = InputBox("What is the column number from the left where the outline level is located? (A=1, B=2, ect...)")
'SECTIONcolumncallout = InputBox("What is the column number from the left where the outline level is located? (A=1, B=2, ect...)")
'
'stop screen updating
Application.ScreenUpdating = False
'
'show gridlines
ActiveWindow.DisplayGridlines = True
'
'Requirement Text to Section Maker --- Part (1)
'Part 1 filter string for the section number. (Numbers 1-10 & . until letters or space)
'Generate a string using the numbers and letters, ex [1.1.3.], cut & copy data to section column same row
For i = HEADERrowcallout + 1 To LASTREQrowcallout
'Get length of active cell. This is max that copied cell will be
LengthCell = Len(Cells(HEADERrowcallout + 1, REQTEXTcolumncallout))
SectionText = (LengthActiveCell)
Reqtext = (LengthActiveCell)
'while count != length, scan each array position from 0 until array position value != 1-10 or .
While x < LengthActiveCell
Select Case Cells()
Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", "."
Dim count As Long
x = x + 1
'If no more letters or .s, move to next cell
x = LengthCell
'if SectionText() = SectionText(0)
'Keep going down ReqText column until specified end
HEADERrowcallout = HEADERrowcallout + 1
End Sub
===========================
Picture of Excel Sheet

Answer 1

Edit: Now with comments explaining what the code does
Obviously you don't need the comments in your live version.
Paste the code below into a new Module, and then use it as a WorksheetFunction
(I took a guess as to what the function should be called). In any cell, enter =ExtractOutline(<cell address>), where <cell address> is the cell from which you wish to extract the x.x.x. bit.
Function ExtractOutline(strInput As String)
'Function iterates through the input string until we get to a
'character which isn't one in "0123456789." Each character which is
'one of these is added to the output as we go along
Dim strOut As String 'The output we're building
Dim intPos As Integer 'The position we've reached in the input
Dim str1Char As String 'The character found at the current position
intPos = 1 'We'll start at the first character
str1Char = Mid(strInput, intPos, 1) 'Extract the intPos-th character, in this case, the 1st.
While intPos <= Len(strInput) And WorksheetFunction.Find(str1Char, "0123456789." & str1Char) < 12
'While
'intPos <= Len(strInput)
'This makes sure we haven't iterated beyond the end of the input
'AND
'WorksheetFunction.Find(str1Char, "0123456789." & str1Char) < 12
'Looks for the current character in "0123456789."
'If it wasn't found we'd get an error (as output to the function)
'To prevent that add current character to end of "0123456789."
'Since "Find" returns the position, within the string,
'and "01234567890." as 11 characters, we only match the right bit if it
'is found before the 12th character
'Add the character to the output
strOut = strOut & Mid(strInput, intPos, 1)
'Increment ready for next time round the loop
intPos = intPos + 1
'Get the next character to be checked
str1Char = Mid(strInput, intPos, 1)
Wend
ExtractOutline = strOut
End Function

Answer 2

Or you can incorporate the following approach into your code...
Sub Alex()
Dim lr As Long
Dim rng As Range, cell As Range
Dim RE As Object
Dim Match As Object
lr = Cells(Rows.Count, 4).End(xlUp).Row
Set rng = Range("D2:D" & lr)
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "([0-9]\.){1,}"
For Each cell In rng
If RE.test(cell.Value) = True Then
Set Match = RE.Execute(cell.Value)
cell.Offset(0, -2).Value = Left(Match(0), Len(Match(0)) - 1)
End If
Next cell
End Sub

Answer 3

Something like this
You can see RegExp sample here
code
Sub EddieBetts()
Dim rng1 As Range
Dim lngCnt As Long
Dim objRegex As Object
Dim X
Set rng1 = Range([d2], Cells(Rows.Count, "D").End(xlUp))
X = rng1.Value2
Set objRegex = CreateObject("VBScript.RegExp")
objRegex.Pattern = "([0-9\.])+"
For lngCnt = 1 To UBound(X, 1)
If objRegex.test(X(lngCnt, 1)) Then X(lngCnt, 1) = objRegex.Execute(X(lngCnt, 1))(0)
Next
rng1.Offset(0, -2).Value2 = X
End Sub