Hi Macropod,
I hope you are keeping well. FYI the code is working great - so much so that I've been asked by my boss if I could do something extra. If you feel this should be added under a new post then please advise but because it's the same code, just altered a bit, I hope it's ok tag onto this?
Compared to above this is much simpler I think, it's just that I'm stuck. Here's the code and below it is my question:
Sub UpdateFindingsData()
Application.ScreenUpdating = False
Dim wdApp As Object, wdDoc As Object, wdRng As Object
Dim WkSht As Worksheet, LRow As Long, i As Long
Dim strFldr As String, strFile As String, StrDoc As String
Dim FSObj As Object, FSOFile As Object, DtTm As Date
Set WkSht = ThisWorkbook.Sheets("Findings")
Sheet5.Unprotect Password:="Secret"
LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdApp = CreateObject("Word.Application")
If wdApp Is Nothing Then
MsgBox "Can't start Word.", vbExclamation
Exit Sub
End If
With WkSht
For i = 1 To LRow
If LCase(.Cells(i, 1).Text) = "true" Then
strFldr = .Cells(i, 2).Text
If Dir(strFldr, vbDirectory) = "" Then
.Cells(i, 3).Value = "Please check Folder Location"
Else
If FSObj Is Nothing Then Set FSObj = CreateObject("Scripting.FileSystemObject")
'loop through each file and get date last modified. If largest date then store Filename
DtTm = DateSerial(1900, 1, 1)
strFile = Dir(strFldr & "\*.doc*", vbNormal)
While strFile <> ""
Set FSOFile = FSObj.GetFile(strFldr & "\" & strFile)
If FSOFile.DateLastModified > DtTm Then
DtTm = FSOFile.DateLastModified
StrDoc = strFldr & "\" & strFile
End If
strFile = Dir()
Wend
Set FSOFile = Nothing
Set wdDoc = wdApp.Documents.Open(Filename:=StrDoc, _
AddToRecentFiles:=False, Visible:=False, ReadOnly:=False)
With wdDoc
Application.CutCopyMode = False
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = 0 'wdFindStop
.Format = True
.Style = "Heading 1"
.MatchWildcards = False
.MatchCase = False
.Text = "Findings^p"
.Replacement.Text = ""
.Execute
End With
If .Find.Found = True Then
Set wdRng = .Duplicate
wdRng.Collapse 0 'wdCollapseEnd
End If
.Start = wdRng.End
With .Find
.Text = "Appendices"
.Execute
End With
If .Find.Found = True Then
wdRng.End = .Duplicate.Start - 1
End If
If Not wdRng Is Nothing Then
With wdRng
If .Tables.Count > 0 Then
With WkSht
Cells(i, 3) = Replace(Replace(wdDoc.Tables(2).Range.Text, Chr(13) & Chr(7) & Chr(13) & Chr(7), Chr(10)), Chr(13) & Chr(7), Space(4))
End With
Application.CutCopyMode = False
End If
End With
Application.CutCopyMode = False
Else
WkSht.Cells(i, 3).Value = "Not Found"
End If
End With
.Close Savechanges:=False
End With
Set wdRng = Nothing
End If
End If
Next
.Columns(3).Cells.Replace What:="¶", Replacement:=Chr(10), _
LookAt:=xlPart, SearchOrder:=xlByRows
.Columns(3).WrapText = True
End With
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
Sheet5.Protect Password:="Secret"
MsgBox "Findings Data has been extracted successfully from the Documents"
End Sub
I'm sure you can see I'm now trying to take the table contents which is found between "Findings" and "Appendices" and put this table directly into one single Excel cell adjacent to the folder location. It works in so far as I reference the table number Tables(2) but I had hoped that the range would capture the specific table between the range because some of the Word Docs can have tables prior to this one. Would you be so kind and advise what I'm doing wrong please? Or perhaps is there a way in vba to take the first table below the Heading "Findings" and put into adjacent cell?
Thanks again Paul - I'll keep trying to fix this but I'm sure you'll figure it out before me so please let me know or point in the direction...
Reply With Quote
I have to try a few tweaks out but when I realised you had replied with the code I just want to buy you the biggest pint of Fosters ever!!! You're the best man! I'll be in touch with my (and no doubt there will be) questions if that's ok? 
Originally Posted by pk247
) I quickly tested the code on my home computer and it works perfectly - I'll try it out in work later and let you know how the real test gets on - I'm sure it'll be grand though. Cheers!