时间戳

首页 > 解决方案 > 使用页码从Word doc中提取包含某个关键字的字符串值到Excel

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

问题描述

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

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

  1. 美国.xxx.xx.xxxxxx
  2. JPA.xxx.xx.xxxxxx
  3. 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 文件开始，请告诉我。

标签： excelvbams-word

解决方案

由于您有不同的搜索模式，您可以将 WordFind与通配符一起使用。在 Word MVP 网站上有一个很好的参考。这将能够Find返回您正在寻找的整个字符串，而无需扩展找到的范围。

找到范围后，您可以检索要传递给 Excel 的文本并使用该Information属性获取页码。

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

您的问题中没有说明您想对页码做什么，因此您需要为此修改下面的代码。

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}”

推荐阅读