拆分数据

关联

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

删除空白

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

如果“.”（点）是要从单元格中的字符串中删除的元素（例如，没有浮点数，也没有“.”是一个重要的标记），您可以使用此代码，包括删除整行。
该代码在指定的范围（oRng）中循环，并且当它找到“..”时，它将用“."替换它。然后，当没有找到更多的“..”时，指示替换作业已经完成，生成错误（捕获），它继续从列“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