從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. 你可以在任何你想要的地方寫出這些值。