从excel打开word文档并将所需信息复制到excel文件中

Question

我有几个word文件。他们建立这样
文本
文本
文本
名称：米克
日期：1-1-1
文本
文本
项：第11项材料：黄金
文本
文本

我正在构建一个可以打开word文件的宏，将名称放在单元格A1中，并将该项放置在单元格A2中。我在互联网上找到了一个代码并对其进行了一些调整。以下代码从单词doc的开头进行选择，直到找到一个单词并将该选择复制到给定的单元格中。

我希望有人能告诉我如何我可以调整这所以选择正确的开始所需的值之前之后的止损下方

代码是项目：

Dim wdApp As Object, wdDoc As Object, wdRng As Object 

Set wdApp = CreateObject("Word.Application") 
With wdApp 
    .Visible = True 
    Set wdDoc = .Documents.Open("path", False, True, False) 
    With wdDoc 
     Set wdRng = .Range(0, 0) 
     With .Range 
     With .Find 
      .Text = "material" 
      .Forward = True 
      .MatchWholeWord = True 
      .MatchCase = True 
      .Execute 
     End With 
     If .Find.found = True Then 
      wdRng.End = .Duplicate.Start 
      Sheets("sheet1").Range("A2").value = wdRng 
     End If 
    End With 
     .Close False 
    End With 
    .Quit 
End With 
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing 

任何人有什么建议？

Answer 1

请尝试以下步骤。它将打开指定的Word文档，通过正则表达式解析所需的值，将这些值放入单元格A1和A2中，然后关闭Word文档。

调用该过程时，指定Word文档的完整路径和文件名。
例如：SetNameAndItem "C:\Temp\Doc1.docx"

Public Sub SetNameAndItem(strPath As String) 
    Dim wdApp As Object: Set wdApp = CreateObject("Word.Application") 
    Dim wdDoc As Object: Set wdDoc = wdApp.Documents.Open(strPath, False, True, False) 
    Dim objRegEx As Object: Set objRegEx = CreateObject("VBScript.RegExp") 
    Dim objMatches As Object 

    On Error GoTo ProcError 

    With objRegEx 
     .Global = False 
     .MultiLine = True 
     .IgnoreCase = False 
     .Pattern = "^Name:\s(.*?)$" 
    End With 

    Set objMatches = objRegEx.Execute(wdDoc.Content) 
    If objMatches.Count = 0 Then 
     Debug.Print "Name: No match." 
    Else 
     Range("A1").Value = objMatches(0).SubMatches(0) 
    End If 

    objRegEx.Pattern = "^Item:\s(.*?)\smaterial" 
    Set objMatches = objRegEx.Execute(wdDoc.Content) 
    If objMatches.Count = 0 Then 
     Debug.Print "Item: No match." 
    Else 
     Range("A2").Value = objMatches(0).SubMatches(0) 
    End If 

ProcExit: 
    On Error Resume Next 
    wdDoc.Close False 
    wdApp.Quit 
    Set objMatches = Nothing 
    Set objRegEx = Nothing 
    Set wdDoc = Nothing 
    Set wdApp = Nothing 
    Exit Sub 
ProcError: 
    MsgBox "Error# " & Err.Number & vbCrLf & Err.Description, , "SetNameAndItem" 
    Resume ProcExit 
End Sub 

结果：

注：请确保您的Word文档中的换行符由正常回车/换行符组合（按下按键的结果g 输入键）。当我从问题中复制/粘贴文本时，文档看起来像预期的那样，但似乎是换行的实际上是垂直制表符，所以正则表达式不起作用。我并不是说你的部分有任何错误，它可能是粘贴网页文字的工具。只是要注意的事情。

UPDATE：

如果在上面的代码中的正则表达式不工作，那么也许这是终究不是复制/粘贴问题，你真的有垂直制表符在文档中。如果是这种情况，请尝试修改Excel VBA代码中的SetNameAndItem过程，如下所示。

（分别为它们使用^和$代表开始和线路的端部，）更换以下两行：

.Pattern = "^Name:\s(.*?)$" 

objRegEx.Pattern = "^Item:\s(.*?)\smaterial" 

随着这两行（其使用\v表示垂直制表）：

.Pattern = "\vName:\s(.*?)\v" 

objRegEx.Pattern = "\vItem:\s(.*?)\smaterial" 

Answer 2

这里是你的问题的一个可能的解决方案：

1. 使用此功能来读取word文件：

   Option Explicit 
   
   Public Function f_my_story() as string 
   
       Dim wdApp  As Object 
       Dim wdDoc  As Object 
   
       Set wdApp = CreateObject("Word.Application") 
   
       With wdApp 
   
        .Visible = True 
        Set wdDoc = .Documents.Open("C:\Users\v\Desktop\text.docx", False, True, False) 
        f_my_story = wdDoc.Range(0, wdDoc.Range.End) 
        wdDoc.Close False 
        .Quit 
   
       End With 
   
   End Function 
   

2. 一旦您已经阅读文件，你会得到一个字符串。现在，您需要一个宏，它将字符串按空格分开，并返回值，这些值位于要查找的值之后。

3. 你可以在任何你想要的地方写出这些值。