Extract data separated by multiple dots from a single cell

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