如何拆分包含“硬回报”的单元格

Question

如何分割包含“硬回车”（段落标记）的单元格，如下图所示？

期望的结果：

这是我的代码

Sub SplitCells()
'
Dim selT As String
Dim arr
Dim i As Integer
selT = selection.Range.Text    
arr = Split(selT, ChrW(13))    
selection.Range.Cut   

  selection.Cells.Split NumRows:=UBound(arr) + 1, NumColumns:=1, MergeBeforeSplit:=False

  selection.MoveDown wdLine, 1
For i = UBound(arr) To 0 Step -1
  selection.MoveUp wdLine, 1
  selection.TypeText arr(i)
Next
End Sub

它有效，但我觉得这段代码很笨拙，希望有人可以告诉我一个优雅的方式。

Answer 1

尝试以下方法;它将拆分所选表中的所有受影响的行。

Sub Demo()
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

与您的方法相比，上述代码还具有保留任何文本格式的优势。

Answer 2

它真的没什么问题。为了在分割/合并单元格的表格中向上/向下移动，您需要Selection ...

这里的代码尽可能使用对象模型而不是Selection。但我不确定我会说它“更优雅”或“不那么笨拙”。可能，它更自我记录，因为它尽可能使用Word对象。

我做的一个改变是在做任何事之前测试选择是否在表中。如果用户忘记选择没有这样测试的单元格，则会显示出神秘的错误消息，这总是很烦人......

Sub SplitCells()
'
    Dim cel As Word.Cell
    Dim selT As String
    Dim arr
    Dim i As Integer
    Dim nrCells As Long

    If Selection.Information(wdWithInTable) Then
        Set cel = Selection.Cells(1)
        selT = cel.Range.Text
        arr = Split(selT, ChrW(13))
        nrCells = UBound(arr)
        cel.Range.Delete

        cel.Split NumRows:=nrCells, NumColumns:=1 ', _
                  'MergeBeforeSplit:=False
        cel.Select
        Selection.MoveDown wdLine, nrCells - 1
        For i = nrCells - 1 To 0 Step -1
            Set cel = Selection.Cells(1)
            cel.Range.Text = arr(i)
            cel.Select
            Selection.MoveUp wdLine, 1
        Next
    Else
        MsgBox "Please select a table cell and try again."
    End If
End Sub