text 拆分表格-18-8-6

Posted 2021-05-02

考虑最后一个单元格为空的情况

Sub SplitCells(ByVal control As IRibbonControl)
Application.ScreenUpdating = False
Dim tt As Single
tt = Timer
Dim selT As String
Dim arr
Dim i, j As Integer
Dim TC As Integer
Dim columnsC As Integer
Dim a, b As Integer
a = selection.Tables(1).columns.count
b = selection.Tables(1).Range.Cells.count
selection.Tables(1).cell(b, a).Range.HighlightColorIndex = wdRed

Do
  selT = selection.Range.Cells(1).Range.Text
    If Len(selT) > 5 Then
    If selection.Cells(1).Range.Paragraphs.count > 1 Then
  
  
    arr = split(selT, ChrW(13))
    Dim p As Integer
    p = selection.Cells(1).Range.Paragraphs.count
    selection.Range.Cells(1).Range.Cut
    selection.Cells.split Numrows:=p, Numcolumns:=1, MergeBeforeSplit:=False
  
    selection.MoveRight wdCell, 2
    
      For j = 0 To UBound(arr) - 1
      
        Dim oriS, doneS As String
        oriS = selection.Paragraphs(1).Range.Text
     If j = 0 Then
      selection.MoveLeft wdCell, 1
       End If
       
      doneS = selection.Paragraphs(1).Range.Text
        If j <> 0 Then
        If oriS = doneS Then
          selection.MoveDown wdLine, 1
        End If
        End If
'        If j = UBound(arr) - 1 Then
'          selection.TypeText Left(arr(j), Len(arr(j)) - 1)
'        Else
'          selection.TypeText arr(j)
'        End If
      selection.TypeText arr(j)
      Next
      
      
      selection.MoveRight Unit:=wdCell
      
      ElseIf selection.Range.Next(wdParagraph, 2).Information(wdWithInTable) Then
    
      selection.MoveRight Unit:=wdCell
      
  End If
  Else

    selection.MoveRight Unit:=wdCell
  End If

  

Loop While selection.Range.HighlightColorIndex <> wdRed


If selection.Range.HighlightColorIndex = wdRed Then
    selT = selection.Range.Cells(1).Range.Text
    If Len(selT) > 5 Then
    If selection.Cells(1).Range.Paragraphs.count > 1 Then
    arr = split(selT, ChrW(13))
    p = selection.Cells(1).Range.Paragraphs.count
    selection.Range.Cells(1).Range.Cut
    selection.Cells.split Numrows:=p, Numcolumns:=1, MergeBeforeSplit:=False
    
    selection.MoveLeft wdCell, 2
    For j = 0 To UBound(arr) - 1
    oriS = selection.Paragraphs(1).Range.Text
    If j = 0 Then
    selection.MoveRight wdCell, 1
    End If
       
      doneS = selection.Paragraphs(1).Range.Text
        If j <> 0 Then
        If oriS = doneS Then
          selection.MoveDown wdLine, 1
        End If
        End If
'        If j = UBound(arr) - 1 Then
'          selection.TypeText Left(arr(j), Len(arr(j)) - 1)
'        Else
'          selection.TypeText arr(j)
'        End If
    selection.TypeText arr(j)
    Next
    Else
  End If
  Else
  End If
End If
selection.Tables(1).Range.HighlightColorIndex = wdAuto
Application.ScreenUpdating = True
End Sub
Sub splitTableNoMerge(ByVal control As IRibbonControl)
On Error GoTo kr



If selection.Tables(1).cell(1, 1).Range.Characters.Last.Previous = vbCr Then
selection.Tables(1).cell(1, 1).Range.Text = "KERRYPNX"
Call splitTableNoMerge1
selection.Tables(1).cell(1, 1).Range.Text = ""
Else
Call splitTableNoMerge1
End If





Dim a, b As Integer
a = 1
b = 2
If a > b Then
kr:
MsgBox "Table has vertically merged cells, please split this merged cells or run split cells function"
End If




End Sub
Sub splitTableNoMerge1()
Application.ScreenUpdating = False
Dim Tbl As table, RngA As Range, RngB As Range
Dim i As Long, l As Long, r As Long, c As Long, p As Long
With selection
  If .Information(wdWithInTable) = False Then
    MsgBox "Please select a table/cell and try again."
    Exit Sub
  End If
  Set Tbl = .Tables(1)
  With Tbl
    l = .columns.count
    For i = .Range.Cells.count To 1 Step -1
      With .Range.Cells(i).Range
        Do While .Characters.Last.Previous = vbCr
          .Characters.Last.Previous = vbNullString
        Loop
      End With
    Next
    For r = .rows.count To 1 Step -1
      With .rows(r)
        If .Range.Paragraphs.count > l + 1 Then
          For c = 1 To .Cells.count
            If .Cells(c).Range.Paragraphs.count > p Then p = .Cells(c).Range.Paragraphs.count
          Next
          If p > 1 Then .Cells.split Numrows:=p, Numcolumns:=1, MergeBeforeSplit:=False
          For c = 1 To .Cells.count
            Set RngA = .Cells(c).Range
            If RngA.Paragraphs.count > 1 Then
              For p = RngA.Paragraphs.count To 2 Step -1
                Set RngB = RngA.Paragraphs(p).Range
                RngB.End = RngB.End - 1
                If Len(RngB.Text) > 0 Then
                  With Tbl.cell(r + p - 1, c).Range
                    .FormattedText = RngB.FormattedText
                    RngB.Delete
                  End With
                End If
                RngA.Paragraphs(p - 1).Range.Characters.Last = vbNullString
              Next
            End If
          Next
        End If
      End With
    Next
  End With
End With
Application.ScreenUpdating = True


End Sub