Sub GetPermitData()
'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strData As String
Dim WkSht As Worksheet, r As Long, c As Long
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document
Set WkSht = ActiveSheet
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
r = r + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
On Error GoTo ErrExit
With wdDoc
Do While .InlineShapes.Count > 0
.InlineShapes(1).Delete
Loop
Do While .Shapes.Count > 0
.Shapes(1).Delete
Loop
With .Range
.Paragraphs.First.Range.Text = vbCr
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = "^13*Permit No.:(*)[ ]@Date Issued:(*)^13*issued to[^13]{1,}(*)^13*Located at (*)^13*:[ ^13]{1,}"
.Replacement.Text = "^t\1^t\2^t\3^t\4^t"
.Execute Replace:=wdReplaceAll
.Text = "[^13 ]@[!^13]@valid until[ ]@<(*).^13*\(PCO\)(*) shall be*Regional Director*[ ^13]{1,}"
.Replacement.Text = "^t\1^t\2"
.Execute Replace:=wdReplaceAll
.Text = "^13[^13 ]{1,}"
.Replacement.Text = Chr(182)
.Execute Replace:=wdReplaceAll
.Text = "([^t" & Chr(182) & "])[ ]{1,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "[ ]{1,}([^t" & Chr(182) & "])"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "(^t*)(^t*)(^t*)(^t*)(^t*)(^t*)(^t*)"
.Replacement.Text = "\3\4\5\1\2\6\7"
.Execute Replace:=wdReplaceAll
End With
End With
strData = Split(.Range.Text, vbCr)(0)
.Close SaveChanges:=False
End With
For c = 1 To UBound(Split(strData, vbTab))
WkSht.Cells(r, c).Value = Split(strData, vbTab)(c)
Next
strFile = Dir()
Wend
GoTo NoErr
ErrExit:
MsgBox "Cannot process:" & vbcr & strFile & vbcr & "Exiting", vbCritical
NoErr:
wdApp.Quit
WkSht.UsedRange.Replace What:=Chr(182), Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
'
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function