VBA将Word中的句子映射/转换为Excel中的列

我试图将Word中的以下格式的信息传输到Excel列“a”、“b”、“c”、“d”，同时忽略前面的数字，该数字是条目的索引（本例中为21）

到目前为止，这是我得到的，但它只适用于左上角的粗体文本，但我不知道如何获得其他子字符串。在此方面的任何帮助都将不胜感激

Sub TheBoldAndTheExcelful()
  Dim docCur As Document
  Dim snt As Range
  Dim i As Integer
  'Requires a reference to the 'Microsoft Excel XX.0 Object Library'
  Dim appXL As Excel.Application, xlWB As Excel.Workbook, xlWS As Excel.Worksheet

  'This assumes excel is currently closed
  Set appXL = CreateObject("Excel.Application")
  appXL.Visible = True
  Set xlWB = appXL.Workbooks.Add
  Set xlWS = xlWB.Worksheets(1)

  On Error GoTo ErrHandler
  Application.ScreenUpdating = False

  Set docCur = ActiveDocument

  For Each snt In docCur.Sentences
    If snt.Bold = True Then
      i = i + 1
      xlWS.Cells(i, 1).Value = snt.Text
    End If
  Next snt

ExitHandler:
  Application.ScreenUpdating = True
  Set snt = Nothing
  Exit Sub

ErrHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

以你为例,

  For Each snt In docCur.Sentences
    If snt.Bold = True Then
      i = i + 1
      xlWS.Cells(i, 1).Value = snt.Text
    End If
  Next snt

让我们先重写一下

  For Each snt In docCur.Sentences
    If snt.Bold = True Then
      i = i + 1
      xlWS.Cells(i, COLUMN_A).Value = snt.Text
    End If
  Next snt

您只包括粗体句子（

，如果snt.bold=True

），并单独写入

列A

你想要的是粗体的句子和后面的三个句子，你想要写四列

因此，将此部分更改为：

'  Dim j As Long ' - make sure to have already declared this, or just uncomment this line

  For j = 1 to docCur.Sentences.Count ' perhaps docCur.Paragraphs instead?
    If docCur.Sentences(j).Bold = True Then
      i = i + 1
      ' used 1+n and j+n for ease of understanding, but you can make these constant with a real solution; or you could even put this in another loop if you wanted, e.g. For n = 0 to 3, ...
      xlWS.Cells(i, 1+0).Value = docCur.Sentences(j+0).Text
      xlWS.Cells(i, 1+1).Value = docCur.Sentences(j+1).Text
      xlWS.Cells(i, 1+2).Value = docCur.Sentences(j+2).Text
      xlWS.Cells(i, 1+3).Value = docCur.Sentences(j+3).Text
    End If
  Next j

或者，为了最大限度地提高性能：

'  Dim j As Long ' - make sure to have already declared this, or just uncomment this line

  With docCur.Sentences ' perhaps docCur.Paragraphs instead?
    For j = 1 To .Count
      If .Item(j).Bold = True Then
        i = i + 1
        xlWS.Cells(i, 1).Resize(, 4).Value = Array(.Item(j + 0).Text, .Item(j + 1).Text, .Item(j + 2).Text, .Item(j + 3).Text)
      End If
    Next j
  End With

根据评论、更改：

---

问题：“还有一些句子，我在第二行略作改动，所以从技术上讲，格式化后总共有5个句子。有没有办法将这两行连接起来，这两行实际上应该代表同一个句子？”：
解决方案：与

和
连接：

示例：

第四项
数组（…）
更改

来自
.Item（j+3）.Text


至
.Item（j+3）.Text和.Item（j+4.Text）

问题：“在创建最后一列时，所有内容都以一些看起来很滑稽的十字架结尾（比如埃及十字架）。你知道如何删除这些十字架吗？”：
解决方案：使用

Left（string，Len（string）-1）删除问题句子中的最后一个字符

，或使用

替换（string，[问题字符]，“”）

示例：

数组（…）中的问题项（假定为第4句）

更改
来自

.Item（j+3）.Text

到

左侧（.Item（j+3）.Text，Len（.Item（j+3）.Text）-1）

更新：

'  Dim j As Long ' - make sure to have already declared this, or just uncomment this line

  With docCur.Sentences ' perhaps docCur.Paragraphs instead?
    For j = 1 To .Count
      If .Item(j).Bold = True Then
        i = i + 1
        xlWS.Cells(i, 1).Resize(, 4).Value = Array(.Item(j + 0).Text, .Item(j + 1).Text, .Item(j + 2).Text, Left(.Item(j + 3).Text, Len(.Item(j + 3).Text) - 1) & .Item(j + 4).Text)
      End If
    Next j
  End With

---

如果这不是一个完整的修复程序，请提供一个示例文件。

出现错误：应用程序定义或对象定义的errorNevermind。修正了这个错误。我得到了2010年的冠军。相反，在创建最后一列时，所有内容都以一些看起来很滑稽的十字架（如埃及安卡）结尾。你知道如何删除这些吗？还有一些句子，我在第二行有一点，所以从技术上讲，自从格式化后总共有5个句子。有没有办法将两行连接起来，这两行实际上应该代表同一个句子？我将根据您的描述尝试对其进行修改，但您能提供一个示例文件吗？