在Excel中查找编号段落并将其复制到各个单元格中

Question

我想将带编号的段落从Word复制到Excel。

我想将以下段落复制到Excel 中的各个单元格中

1. 标题
   这是段

2. 标题2
   这是段

3. 标题3
   这是段

4. 这本身就是一段

我可以通过下面的功能计算编号项目的数量，但一直处于复制和中断状态，直到另一个编号项目。

count_observations = ActiveDocument.Content.ListFormat.CountNumberedItems(Level:=1)

Answer 1

谢谢，我通过研究和搜索其他帖子终于找到了答案。以下是我提出的解决方案。

Sub AutoDatabase()
excel_path = "D:/test.xlm"
Dim obs_range1 As Word.Range
Dim obs_range2 As Word.Range
Dim response_range1 As Word.Range
Dim response_range2 As Word.Range

Dim obs As String
Dim response As String
Dim Z As Integer
Set obs_range1 = ActiveDocument.Range
Set obs_range2 = ActiveDocument.Range
Set response_range1 = ActiveDocument.Range
Set response_range2 = ActiveDocument.Range

x = ActiveDocument.Content.ListFormat _
.CountNumberedItems(Level:=1)

For y = 1 To x

If obs_range1.Find.Execute(FindText:="CopyThis") Then
Set obs_range2 = ActiveDocument.Range(obs_range1.End, ActiveDocument.Range.End)
If obs_range2.Find.Execute(FindText:="CopyThis") Then
obs = ActiveDocument.Range(obs_range1.End, obs_range2.Start).Text

If response_range1.Find.Execute(FindText:="Branch Comments") Then
Set response_range2 = ActiveDocument.Range(response_range1.End, ActiveDocument.Range.End)
If response_range2.Find.Execute(FindText:="CopyThis") Then
response = ActiveDocument.Range(response_range1.End, response_range2.Start).Text
'MsgBox (response)

With ActiveDocument.Tables(1).Rows.Add
With ActiveDocument.Tables(1).Cell(y, 1).Range
.Text = obs
End With
With ActiveDocument.Tables(1).Cell(y, 2).Range
.Text = response
End With
End With

End If
End If
End If
End If
'MsgBox (obs)
Next y
' Remove ^p from table(1)
With ActiveDocument.Tables(1).Range
.Find.Execute FindText:="^p", ReplaceWith:="", Replace:=wdReplaceAll
End With


End Sub