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

这没什么错，真的。为了在具有拆分/合并单元格的表中向上/向下移动，您需要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

Answer 2

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

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

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

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

2 个答案: