搜索Word文檔並在Excel中列出值

Question

好的， 我一直在編寫代碼來自動執行任務。我有一個300字的文檔，每個文檔都有一個標識號，一個標題和一個網站。我想通過標識符搜索文件，分別將標題和網站分別放入excel表格。標識符已經在excel中列出，我希望它們與適當的信息匹配。

我知道它真的，真的凌亂 -

Public Sub ParseDoc() 

Dim list As Workbook 
Dim doc As Document 
Set doc = "C:\network\path\importantlist.doc" 
Dim paras As Paragraphs 
Set paras = doc.Paragraphs 
Dim para As Paragraph 
Dim sents As Sentences 
Dim sent As Range 
Set list = ActiveSheet 
Dim i As Integer 
Dim mystring As String 
Dim length As Integer 
Dim space As String 
Dim dot As String 
Dim space1 As String 
Dim space2 As String 
Dim XYZ As Range 

dot = "." 
space = " " 
i = 1 

While i < 300 'This loops for the duration of the identifier list in excel 
    mystring = Cells(i, 1) ' this pulls the unique identifier from the cell 
For Each para In paras 

    Set sents = para.Range.Sentences ' this searches the document by paragraphs to sentences 
    For Each sent In sents 
     If InStr(1, sent, mystring) <> 0 Then 'If a the identifier is found 
      space1 = InStr(1, sent, space, vbTextCompare) 'measure the length to the first blank space (this indicates the title is about to begin) 
      space2 = InStr(1, sent, dot, vbTextCompare) ' This dot is the ".doc" and indicates the title has concluded, I want the text between these two characters 
       Set XYZ = 
       Start:= space1.range.start 
       End:= space2.range.start 
       'Here is where I am stuck, I have never used range or selection before and after looking around, I still feel very much at a loss on how to proceed forward... 




    Next 

Next 

End Sub 

Answer 1

更新時間：

• 更新值匹配ID
• 追加到沒有匹配的ID記錄

通用儀器ctions

• 插入此成Excel的代碼模塊
• 設置正確的價值觀爲常數ParseWordDocument()
• 交叉着你的手指
• 運行ParseWordDocument()
• 讓我知道如何去

 

    Option Explicit 

    Sub ParseWordDocument() 
     Const WordPath As String = "C:\Users\best buy\Downloads\stackoverflow\Sample Files\A203 Paralegal.docx" 
     Const iID = 1 
     Const iTitle = 2 
     Const iHyperLink = 3 
     Const TargetSheetName As String = "Sheet1" 
     Dim k As String, id As String, title As String, hAddress As String, hScreenTip As String, hTextToDisplay As String 
     Dim lastRow As Long, x As Long, y As Long 
     Dim arData, h 

     arData = getWordDocArray(WordPath, False) 

     With Worksheets(TargetSheetName) 

      lastRow = .Cells(Rows.Count, iID).End(xlUp).Row + 1 

      For x = 2 To lastRow 

       For y = 0 To UBound(arData, 2) 
        id = Trim(.Cells(x, iID)) 
        If Len(id) And (id = arData(0, y)) Then 
         id = Trim(.Cells(x, iID)) 
         title = arData(1, y) 
         hAddress = arData(2, y) 
         hScreenTip = arData(3, y) 
         hTextToDisplay = arData(4, y) 

         .Cells(x, iTitle) = title 
         .Hyperlinks.Add .Cells(x, iHyperLink), Address:=hAddress, ScreenTip:=hScreenTip, TextToDisplay:=hTextToDisplay 
         arData(0, y) = "" 
         Exit For 
        End If 

       Next 

      Next 

      For y = 0 To UBound(arData, 2) 

       id = arData(0, y) 
       If Len(id) Then 
        title = arData(1, y) 
        hAddress = arData(2, y) 
        hScreenTip = arData(3, y) 
        hTextToDisplay = arData(4, y) 

        .Cells(lastRow, iID) = id 
        .Cells(lastRow, iTitle) = title 
        .Hyperlinks.Add .Cells(lastRow, iHyperLink), Address:=hAddress, ScreenTip:=hScreenTip, TextToDisplay:=hTextToDisplay 
        arData(0, y) = "" 
        lastRow = lastRow + 1 
       End If 

      Next 

     End With 


    End Sub 

    Function getWordDocArray(WordPath As String, Optional ShowWord As Boolean = False) As Variant 
     Dim i As Integer, iStart As Integer, iEnd As Integer 
     Dim id As String, title As String 
     Dim arData, s 
     Dim wdApp, wdDoc, h 

     Set wdApp = CreateObject("Word.Application") 
     Set wdDoc = wdApp.Documents.Open(Filename:=WordPath, ReadOnly:=True) 

     wdApp.Visible = ShowWord 

     ReDim arData(4, 0) 

     For Each s In wdDoc.Sentences 
      On Error GoTo SkipSentence 

      iStart = InStr(s.Text, s.Words(2)) 
      iEnd = InStr(s.Text, "(") - iStart 
      id = Trim(s.Words(1)) 
      title = Mid(s.Text, iStart, iEnd) 
      Set h = s.Hyperlinks(1) 

      ReDim Preserve arData(4, i) 
      arData(0, i) = id 
      arData(1, i) = title 
      arData(2, i) = h.Address 
      arData(3, i) = h.ScreenTip 
      arData(4, i) = h.TextToDisplay 

      i = i + 1 
    SkipSentence: 
      On Error GoTo 0 
     Next 

     getWordDocArray = arData 

     If Not ShowWord Then 
      wdDoc.Close False 
      wdApp.QUIT 
     End If 

     Set wdDoc = Nothing 
     Set wdApp = Nothing 
    End Function