Process Macro for all .doc in Directory

[Katamari]

I have a macro that extracts data from a .doc and plugs it into a new .xlsx. I'd like to be able to run the macro so it extracts data from all .doc in a folder into one worksheet. Is that possible?

Here's my macro:


Sub ExportExcel()
Dim app As Object
Dim wbk As Object
Dim wsh As Object
Dim r As Long
Dim arrParagraphs As Variant
Dim paragraph As Variant
Dim iPos1 As Integer
Dim iPos2 As Integer


' Start Excel

On Error Resume Next

Set app = GetObject(Class:="Excel.Application")

If app Is Nothing Then

Set app = CreateObject(Class:="Excel.Application")

If app Is Nothing Then

MsgBox "Can't start Excel!", vbExclamation

Exit Sub

End If

End If

On Error GoTo ErrHandler

' Create workbook with one worksheet

app.ScreenUpdating = False

Set wbk = app.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet

Set wsh = wbk.Worksheets(1)

r = 1

wsh.Cells(r, 1) = "Name"
wsh.Cells(r, 2) = "Address"
wsh.Cells(r, 3) = "City"
wsh.Cells(r, 4) = "State"
wsh.Cells(r, 5) = "ZIP"
wsh.Cells(r, 6) = "Country"
wsh.Cells(r, 7) = "Telephone"
wsh.Cells(r, 8) = "Email"
wsh.Cells(r, 9) = "Company"
wsh.Cells(r, 10) = "Title"
wsh.Cells(r, 11) = "Rank"

arrParagraphs = Split(ActiveDocument.Content, Chr$(13) & ",")

For Each paragraph In arrParagraphs
Dim arrSentences As Variant

arrSentences = Split(paragraph, Chr$(13))

For i = LBound(arrSentences) To UBound(arrSentences)

If arrSentences(i) = "Contacts Database" Then
'Add 1 to r because we are at a new entry.
r = r + 1
'Load Name
wsh.Cells(r, 1) = Trim(arrSentences(i + 4))
End If

If Mid(arrSentences(i), 1, 10) = "Telephone:" Then
'Load Phone
wsh.Cells(r, 7) = "+1" & Trim(Mid(arrSentences(i), 11))
End If

If Mid(arrSentences(i), 1, 7) = "E-Mail:" Then
'Load Email
wsh.Cells(r, 8) = Trim(Mid(arrSentences(i), 8))
End If

If Mid(arrSentences(i), 1, 8) = "Company:" Then
'Load Company
wsh.Cells(r, 9) = Trim(Mid(arrSentences(i), 9))
End If

If Mid(arrSentences(i), 1, 6) = "Title:" Then
'Load Title
wsh.Cells(r, 11) = Trim(Mid(arrSentences(i), 7))
End If

If Mid(arrSentences(i), 1, 9) = "Function:" Then
'Load Rank
wsh.Cells(r, 10) = Trim(Mid(arrSentences(i), 10))
End If

If Mid(arrSentences(i), 1, 8) = "Address:" Then
'Loads Street Number
wsh.Cells(r, 2) = Trim(Mid(arrSentences(i), 9, InStr(9, arrSentences(i), ",") - 9))
'Loads City
iPos1 = fFindNthOccur(arrSentences(i), ",", 1) + 1
iPos2 = fFindNthOccur(arrSentences(i), ",", 2)
wsh.Cells(r, 3) = Trim(Mid(arrSentences(i), iPos1, iPos2 - iPos1))
'Loads State
iPos1 = fFindNthOccur(arrSentences(i), ",", 2) + 1
iPos2 = fFindNthOccur(arrSentences(i), ",", 3)
wsh.Cells(r, 4) = Trim(Mid(arrSentences(i), iPos1, iPos2 - iPos1))
'Loads Zip
iPos1 = fFindNthOccur(arrSentences(i), ",", 3) + 1
iPos2 = fFindNthOccur(arrSentences(i), ",", 4)
wsh.Cells(r, 5) = Trim(Mid(arrSentences(i), iPos1, iPos2 - iPos1))
'Loads Country
iPos1 = fFindNthOccur(arrSentences(i), ",", 4) + 1
wsh.Cells(r, 6) = IIf(Trim(Mid(arrSentences(i), iPos1)) = "UNITED STATES", "USA", Trim(Mid(arrSentences(i), iPos1)))
End If

Next i
Next


ExitHandler:

If Not app Is Nothing Then

wsh.Range("A1:J1").EntireColumn.AutoFit

app.ScreenUpdating = True

app.Visible = True

End If

Exit Sub

ErrHandler:

MsgBox Err.Description, vbExclamation

Resume ExitHandler
End Sub

Public Function fFindNthOccur(ByVal pStr As String, _
pFind As String, _
pNth As Integer) As Integer
'------------------------------------------------------------------
' Purpose: Return location of nth occurence of item in a string.
' Arguments: pStr: The string to be searched.
' pFind: The item to search for.
' pNth: The occurence of the item in string.
'------------------------------------------------------------------
Dim strHold As String
Dim strFind As String
Dim intHold As Integer
Dim intSay As Integer
Dim intKeep As Integer
Dim n As Integer

strHold = pStr
strFind = pFind
intHold = pNth
intKeep = 0
n = 0

Do While n < intHold
If InStr(strHold, strFind) = 0 Then
fFindNthOccur = 0
Exit Do
Else
intSay = InStr(1, strHold, strFind)
intKeep = intKeep + intSay
n = n + 1
strHold = Mid(strHold, intSay + Len(strFind))
fFindNthOccur = intKeep
End If
Loop

End Function


I appreciate any help. Thank you.

[macropod]

This appears to be a follow-up to your thread which I answered this (quite comprehensively) at: http://social.msdn.microsoft.com/Forums/en-US/worddev/thread/323cadb9-ddb2-437d-8c56-52c42fd85b2e

Your posts in that thread stated quite categorically that you had one only document, with hundreds of pages, to process. It would be helpful if you could provide consistent advice about your requirements. I note too that you've elected not to use the code I provided.