Searching a Word Document and listing values in Excel - vba

Question

Alright,
I've been cobbling together code to automate a task. I have a word document that has something like 300 lines that each have an identifier number, a title, and a website. I would like to search the document by identifier pull the title and website separately and enter them into an excel sheet separately. The identifiers are already listed in excel and I would like them to match up with the appropriate information.
I know its really, really messy -
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

Updated:
Updates values for matching IDs
Appends records that have no matching ID
General Instructions
Insert this into a Excel code module
Set the correct values for the constants in ParseWordDocument()
Cross you finger
Run ParseWordDocument()
Let me know how it went
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