Extract data separated by multiple dots from a single cell - excel

Question

The cells contain different lengths of data. I tried text to column. It does not work because of the number of dots.
How can I populate each text or number in separate cells by ignoring the number of dots than delete the line anywhere there is an empty cell in column A and B?
Data exemple:

Answer 1

Split Data
Associated
Sub SplitAssociated()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "B1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim srg As Range
Dim rCount As Long
With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
Dim slCell As Range
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
rCount = slCell.Row - .Row + 1
Set srg = .Resize(rCount)
End With
Dim Data As Variant
Data = sws.Evaluate("TRIM(SUBSTITUTE(" & srg.Address & ",""."","" ""))")
Dim SubStrings() As Variant: ReDim SubStrings(1 To rCount)
Dim Lens() As Long: ReDim Lens(1 To rCount)
Dim r As Long
Dim cCount As Long
Dim cString As String
For r = 1 To rCount
cString = Data(r, 1)
If Len(cString) > 0 Then
SubStrings(r) = Split(cString)
Lens(r) = UBound(SubStrings(r)) + 1
If Lens(r) > cCount Then cCount = Lens(r)
End If
Next r
ReDim Data(1 To rCount, 1 To cCount)
Dim c As Long
For r = 1 To rCount
For c = 1 To Lens(r)
Data(r, c) = SubStrings(r)(c - 1)
Next c
Next r
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(rCount, cCount)
drg.Value = Data
drg.Resize(dws.Rows.Count - drg.Row - rCount + 1).Offset(rCount).Clear
End Sub
Remove Blanks
Sub SplitRemoveBlanks()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "C1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim srg As Range
Dim srCount As Long
With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
Dim slCell As Range
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
srCount = slCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
Dim Data As Variant
Data = sws.Evaluate("TRIM(SUBSTITUTE(" & srg.Address & ",""."","" ""))")
Dim SubStrings() As Variant: ReDim SubStrings(1 To srCount)
Dim Lens() As Long: ReDim Lens(1 To srCount)
Dim sr As Long
Dim drCount As Long
Dim dcCount As Long
Dim cString As String
For sr = 1 To srCount
cString = Data(sr, 1)
If Len(cString) > 0 Then
drCount = drCount + 1
SubStrings(sr) = Split(cString)
Lens(sr) = UBound(SubStrings(sr)) + 1
If Lens(sr) > dcCount Then dcCount = Lens(sr)
End If
Next sr
ReDim Data(1 To drCount, 1 To dcCount)
Dim dr As Long
Dim dc As Long
For sr = 1 To srCount
If Lens(sr) > 0 Then
dr = dr + 1
For dc = 1 To Lens(sr)
Data(dr, dc) = SubStrings(sr)(dc - 1)
Next dc
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = Data
drg.Resize(dws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear
End Sub

Answer 2

If the "." (dot) is the element to be stripped from strings in cells (eg no floating point numbers, nor "." is an important mark), you can use this code including deleting entire lines.
The code loops through the specified range (oRng) and when it finds ".." it will replace it with ".". Then, when no more ".." is found, indicating that the replacement job has completed, generating an error (caught), it proceeds to delete the blank rows from the blank cells in column "A".
Option Explicit
Sub fnCleanAndSplit()
Dim oRng As Excel.Range
Dim oCell As Excel.Range
Dim fDone As Boolean
Set oRng = ThisWorkbook.Sheets(1).Range("A1:A7")
Do
For Each oCell In oRng.Cells
oCell.Value = VBA.Replace(oCell.Value, "..", ".")
Next
On Error GoTo lblDone
fDone = oRng.Find("..") = ""
On Error GoTo 0
Loop Until fDone
lblDone:
oRng.TextToColumns Destination:=oRng.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
:=".", TrailingMinusNumbers:=True
oRng.SpecialCells(xlCellTypeBlanks).Select
oRng.Parent.Activate 'just in case it is not activated
Selection.EntireRow.Delete
End Sub