将标准word中的内容按字段提取到excel时遇到的问题

jdhi

我用以下的宏可以将规格化的word文字按字段提取到excel中。但是遇到一个问题：比如下面成果简介，只能提取成果简介后面第一段文字，也就是第一个回车之前的内容。能不能把成果简介中所有的内容都提起呢。在格式判断上，每个成果都有以成果简介和成果创新性为开头的两个段落，只需要能设置成果简介的提取内容是 “成果简介：” 和“成果创新性：”这两个关键字之间的内容就行。

Sub 宏1()
Dim oApp As Object
  Dim oappwork, 接收表
  Set oApp = CreateObject("Excel.Application")
  Set oappwork = oApp.Workbooks.Add
  Set 接收表 = oappwork.Sheets(1)
  行 = 1
  接收表.Cells(1, 1) = "项目名称"
  接收表.Cells(1, 2) = "成果简介"

  
  For i = 1 To ActiveDocument.Paragraphs.Count
    If InStr(ActiveDocument.Paragraphs(i).Range.Text, "项目名称") > 0 Then
      行 = 行 + 1
      接收表.Cells(行, 1) = ActiveDocument.Paragraphs(i).Range.Text
    ElseIf InStr(ActiveDocument.Paragraphs(i).Range.Text, "成果简介") > 0 Then
      接收表.Cells(行, 2) = Replace(ActiveDocument.Paragraphs(i).Range.Text, "成果简介：", "")

   
    End If
  Next i
  oApp.Visible = True

End Sub

duquancai

简单粗暴的在“你的代码基础上”改的！！！！！！！！！！！！！！！
Sub 宏1()
    Dim oApp As Object
    Dim oappwork, 接收表
    Dim myStart&, Doc As Document, p As Range, s As Range
    Set oApp = CreateObject("Excel.Application")
    Set oappwork = oApp.Workbooks.Add
    Set 接收表 = oappwork.Sheets(1)
    接收表.Cells(1, 1) = "项目名称"
    接收表.Cells(1, 2) = "成果简介"
    Set Doc = ActiveDocument
    Set p = Doc.Content: Set s = p.Duplicate
    With s.Find
        Do While .Execute("项目名称")
            If Not s.InRange(p) Then Exit Do
            n = n + 1
            With s
                If n > 1 Then
                    接收表.Cells(n, 1) = Doc.Range(myStart, .Start).Paragraphs(1).Range.Text
                    With Doc.Range(myStart, .Start).Find
                        If .Execute("成果简介*成果创新性", , , -1) Then
                            With .Parent
                                .Start = .Start + 5: .End = .End - 5
                                接收表.Cells(n, 2) = .Text
                            End With
                        End If
                    End With
                End If
                myStart = .Start: .SetRange .End, .End
            End With
        Loop
    End With
    If n > 0 Then
        接收表.Cells(n + 1, 1) = Doc.Range(myStart, p.End).Paragraphs(1).Range.Text
        With Doc.Range(myStart, p.End).Find
            If .Execute("成果简介*成果创新性", , , -1) Then
                With .Parent
                    .Start = .Start + 5: .End = .End - 5
                    接收表.Cells(n + 1, 2) = .Text
                End With
            End If
        End With
    End If
    oApp.Visible = True
End Sub