使用页码从Word文档到Excel中提取包含某个关键字的字符串值

问题描述

我是VBA的新手，正在尝试从Word文档中提取一些包含某个关键字的字符串值到Excel。例如，有一些国家代码，例如USA.001.01.033592，我想从单词doc中提取所有看起来像国家代码的字符串值，然后将它们收集到Excel电子表格中。

我正在查看的国家/地区代码格式

USA.xxx.xx.xxxxxx
JPA.xxx.xx.xxxxxx
FRA.xxx.xx.xxxxxx X代表数字，问题是这些代码位于主体段落，段落内的表格和脚注中。另外，当我检索代码时，我也想提取页码。

是否可以通过页面编号一次从主要段落，表格和脚注中提取所需数据？

我的代码草稿很粗，但根本没有用。谁能帮忙吗？

这是我的代码：

Option Explicit

Sub Footnotes()

    Dim appExcel As Object
    Dim objSheet As Object
    Dim arange As Range
    Dim intRowCount As Integer
    intRowCount = 1
    Set arange = ActiveDocument.Range

    With arange.Find
    Do
        .Text = "USA." or "JPA." or "FRA."
        .Execute
        If .Found Then
            arange.Expand Unit:=wdSentence
            arange.copy
            arange.Collapse wdCollapseEnd
            If objSheet Is nothing Then
               Set appExcel = CreateObject("Excel.Application")
               Set objSheet = appExcel.workbooks.Open("C:\Users\Footnotes.xlsx").Sheets("Sheet1")
               intRowCount = 1
            End If
            objSheet.Cells(intRowCount,1).Select
            objSheet.Paste
            intRowCount = intRowCount + 1
        End If
        Loop While .Found
    End With

    If Not objSheet Is nothing Then
    appExcel.workbooks(1).Close True
    appExcel.Quit
    Set objSheet = nothing
    Set appExcel = nothing
    End If
    Set arange = nothing

End Sub

当前，我正在尝试从Word文档中使用VBA，但如果最好从excel文件开始，请告诉我。

解决方法

由于您有独特的搜索模式，因此可以将Word的Find与通配符一起使用。 Word MVP网站上有一个good reference。这将使Find可以返回您要查找的整个字符串，而无需扩展找到的范围。

一旦找到了范围，就可以使用Information属性检索文本以传递到Excel并获取页码。

Word文档由许多部分组成，称为StoryRanges。尽管表格只是包含它们的范围的一部分，但脚注包含在单独的StoryRange中。下面的代码遍历StoryRanges并检查当前type是哪个。我这样做是为了让您可以根据需要添加其他类型。

您的问题中没有提到要使用页码做什么，因此您需要为此修改以下代码。

Sub Footnotes()

   Dim appExcel As Excel.Application
   Dim objSheet As Excel.Worksheet
   Dim findRange As Range
   Dim intRowCount As Integer
   Dim pageNum As Long
   
   If objSheet Is Nothing Then
      Set appExcel = CreateObject("Excel.Application")
      Set objSheet = appExcel.workbooks.Open("C:\Users\Footnotes.xlsx").Sheets("Sheet1")
   End If
   intRowCount = 2
   
   'Set findRange = ActiveDocument.Range
   For Each findRange In ActiveDocument.StoryRanges
      With findRange.Find
         .Text = "[UJF][PRS]A.[0-9]{3}.[0-9]{2}.[0-9]{6}"
         .MatchWildcards = True
         Do While .Execute = True
            pageNum = CLng(findRange.Information(wdActiveEndPageNumber))
            objSheet.Cells(intRowCount,1).Value = findRange.Text
            objSheet.Cells(intRowCount,2).Value = pageNum
            intRowCount = intRowCount + 1
            findRange.Collapse wdCollapseEnd
         Loop
      End With
   Next findRange

   If Not objSheet Is Nothing Then
      appExcel.workbooks(1).Close True
      appExcel.Quit
      Set objSheet = Nothing
      Set appExcel = Nothing
   End If
   Set findRange = Nothing
End Sub

编辑：上面的代码只能找到问题中列出的国家代码。要查找任何国家或地区代码，请将Find.Text更改为“ [AZ] {3}。[0-9] {3}。[0-9] {2}。[0-9] {6}”

excel excel ms-word