Try:
Option Explicit
Sub sExtractValues(rValue As Range)
Dim sText As String
sText = rValue.Text
Dim vArrayIn
Dim vArrayOut(1 To 3)
vArrayIn = Split(rValue.Text, ".")
vArrayOut(1) = vArrayIn(LBound(vArrayIn))
vArrayOut(2) = Left(vArrayIn(UBound(vArrayIn)), 2)
vArrayOut(3) = Right(vArrayIn(UBound(vArrayIn)), 2)
rValue.Offset(0, 1).Resize(1, 3) = vArrayOut
End Sub
Sub TestExtractValues()
sExtractValues Range("A2")
End Sub
Sub TestExtractValuesAll()
Dim lLR As Long, i As Long
lLR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lLR
sExtractValues Range("A" & i)
Next 'i
End Sub
Function fExtractValues(rValue As Range)
' worksheet example: =fExtractValues($A1)
' Array Entered into 3 cells using Ctrl-Shift-Enter
' for example, select F1:H1
' type =fExtractValues($A1)
' and press Ctrl-Shift-Enter
' drag down if appropriate
Dim sText As String
sText = rValue.Text
Dim vArrayIn
Dim vArrayOut(1 To 3)
vArrayIn = Split(rValue.Text, ".")
vArrayOut(1) = vArrayIn(LBound(vArrayIn))
vArrayOut(2) = Left(vArrayIn(UBound(vArrayIn)), 2)
vArrayOut(3) = Right(vArrayIn(UBound(vArrayIn)), 2)
fExtractValues = Application.Transpose(Application.Transpose(vArrayOut()))
End Function
See the example.
Bookmarks