Loop through all Word documents in directory.

Hi Experts!

Okay, i've looked through a load of solutions and tried to amend my code, but i can't get it working so i require help.

My code, when started asks for the user to select a folder and then select a file (*.docx) from within. The macro then strips most of the date from the filename leaving only the first part of the date. It uses this information to determine which worksheet it should use. It then imports the table from the word document, pastes it to the relevant worksheet and formats the worksheet.
Once this is complete, it will ask the user for another Word document.

What i would like to do, is have the user select the directory in the first instance and basically for it to open the first Word document it comes across, my macro would then process that Word document, closes it and then opens the next available word document in the folder.

Here is my working code. I just need it to loop...

Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim WhichDay As String
Dim LastSepPos As Long
Dim myStr As String
Dim FileName As String
Dim NewStr As String
        
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)

Set wdDoc = GetObject(wdFileName) 'open Word file
    
With wdDoc
TableNo = wdDoc.tables.Count
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & _
"Enter table number of table to import", "Import Word Table", "1")
End If

'Format the name of the document removing year/month and day leaving only a day number
LastSepPos = InStrRev(wdFileName, "\")
FileName = Mid(wdFileName, LastSepPos + 1)
NewStr = MakeNumeric(FileName)

WhichDay = NewStr
Sheets("Day " & WhichDay).Activate

With .tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 3 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(iRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Next iCol
Next iRow
End With
End With

Set wdDoc = Nothing

'Now format the Worksheet to look correct and remove incorrect entries
Cells.Replace What:="Closed", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:="Medium", Replacement:="Med", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:="mins", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Cells.Replace What:="minutes", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:="min", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Cells.Replace What:=" / <1hr", Replacement:="60", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:=" / 1day", Replacement:="60", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Columns("A:A").ColumnWidth = 16.14
Columns("B:B").ColumnWidth = 11
Columns("C:C").ColumnWidth = 6
Columns("D:D").ColumnWidth = 13.14
Columns("E:E").ColumnWidth = 7
Columns("F:F").ColumnWidth = 37
Columns("G:G").ColumnWidth = 10
Columns("H:H").ColumnWidth = 16

Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
:="-", FieldInfo:=Array(1, 4), TrailingMinusNumbers:=True
Range("A3").Select

'Convert the fault stats from numbers to text descriptions
Call WordImport1_Loop
Call WordImport2_Loop
Call WordImport3_Loop
Call WordImport4_Loop
Call WordImport5_Loop
Call WordImport6_Loop
Call WordImport7_Loop
Call WordImport8_Loop
Call WordImport9_Loop
Call WordImport10_Loop
Call WordImport11_Loop
Call WordImport12_Loop

'Call the macro again to obtain another document
ImportWordTable

End Sub

Open in new window


Many thanks in advance.
vestanpance_ukAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

PC_BobCommented:
You may want to check out this link (if you haven't seen it already): http://support.microsoft.com/kb/139724

Here's the code from the link above modified to look for docx files and use your code:
Sub DirLoop()

      Dim MyFile As String, Sep As String

      ' Sets up the variable "MyFile" to be each file in the directory
      ' This example looks for all the files that have an .xls extension.
      ' This can be changed to whatever extension is needed. Also, this
      ' macro searches the current directory. This can be changed to any
      ' directory.

      ' Test for Windows or Macintosh platform. Make the directory request.
      Sep = Application.PathSeparator

      If Sep = "\" Then
         ' Windows platform search syntax.
         MyFile = Dir(CurDir() & Sep & "*.docx")

      End If

      ' Starts the loop, which will continue until there are no more files
      ' found.

      Do While MyFile <> ""

         'Calls your ImportWordTable procedure
         ImportWordTable
         MyFile = Dir()
      Loop

   End Sub

Open in new window

0
vestanpance_ukAuthor Commented:
Thanks for your input PC_Bob, but unfortunately it didn't work....

I tried running the macro, but it didn't even select a folder let alone run the macro..

I even tried wrapping the code around my macro which imported one word document and then failed with a debug error.
It's the more or less the same error i was getting when i was trying to work out the code myself.
Besides which, i do want the code to be wrapped around my macro where possible to keep it cleaner. Perhaps the code i've cobbled together is convoluted, but it works...

I have done this before about a year ago, but sadly it doesn't seem to work anymore and i don't know why.....
I figured it would just be easier to start from scratch....

Any other solutions that can help would be much appreciated..

Cheers
Daz
0
vestanpance_ukAuthor Commented:
OK, i have managed to fix my old Word Document importer...

It might be long winded, but it works...

My code sits under the ProcessDocument Sub...

Here's the (very long) code..

Private mobjWordApp As Word.Application
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'The following code will add a browse to local drive / folder window if you wish the user to chose a local file themselves.
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Sub RunMe()
Dim FolderName As String
Application.ScreenUpdating = False
'late binding?
AddRunTimeScripting
AddRunTimeWord
'Chose your initial directory.
ProcessDirectory GetFolderName("Select a folder")
Application.ScreenUpdating = True
End Sub

Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function

Property Get WordApp() As Word.Application
  If mobjWordApp Is Nothing Then
Set mobjWordApp = CreateObject("Word.Application")
mobjWordApp.Visible = True
  End If
  Set WordApp = mobjWordApp
End Property

Sub CloseWordApp()
  If Not (mobjWordApp Is Nothing) Then
On Error Resume Next
mobjWordApp.Quit
Set mobjWordApp = Nothing
  End If
End Sub

Function GetWordDocument(FileName As String) As Word.Document
On Error Resume Next
Set GetWordDocument = WordApp.Documents.Open(FileName)
If Err.Number = &H80010105 Then
  CloseWordApp
  On Error GoTo 0
  Set GetWordDocument = WordApp.Documents.Open(FileName)
End If
End Function

Sub ProcessDirectory(PathName As String)
  Dim fso As New FileSystemObject
  Dim objFile As File
  Dim objFolder As Folder
  Dim objWordDoc As Object

  On Error GoTo Err_Handler

  Set objFolder = fso.GetFolder(PathName)
  For Each objFile In objFolder.Files
If StrComp(Right(objFile.Name, 4), ".docx", vbTextCompare) = 1 Then
  Set objWordDoc = GetWordDocument(objFile.path)
  ' objWordDoc.Unprotect Password:="testcode" ' Need to check if it has Password?
  ProcessDocument objWordDoc
  objWordDoc.Close 0, 1
  Set objWordDoc = Nothing
End If
  Next

Exit_Handler:
  CloseWordApp
  Exit Sub

Err_Handler:
  MsgBox "Error " & Err.Number & ": " & Err.Description
  Resume Exit_Handler
  'Resume Next ' or as above
End Sub

Sub ProcessDocument(objWordDoc As Document)
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim LR As Long
Dim WhichDay As String
Dim LastSepPos As Long
Dim myStr As String
Dim FileName As String

Set wdDoc = objWordDoc 'GetObject(wdFileName) 'open Word file

With wdDoc
TableNo = wdDoc.tables.Count
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & _
"Enter table number of table to import", "Import Word Table", "1")
End If

'Format the name of the document removing year/month and day leaving only a day number
LastSepPos = InStrRev(objWordDoc, "\")
FileName = Mid(objWordDoc, LastSepPos + 1)
NewStr = MakeNumeric(FileName)

WhichDay = NewStr
Sheets("Day " & WhichDay).Activate

With .tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 3 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(iRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Next iCol
Next iRow
End With
End With

Set wdDoc = Nothing

'Now format the Worksheet to look correct and remove incorrect entries
Cells.Replace What:="Closed", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:="Medium", Replacement:="Med", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:="mins", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Cells.Replace What:="minutes", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:="min", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Cells.Replace What:=" / <1hr", Replacement:="60", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Cells.Replace What:=" / 1day", Replacement:="60", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Columns("A:A").ColumnWidth = 16.14
Columns("B:B").ColumnWidth = 11
Columns("C:C").ColumnWidth = 6
Columns("D:D").ColumnWidth = 13.14
Columns("E:E").ColumnWidth = 7
Columns("F:F").ColumnWidth = 37
Columns("G:G").ColumnWidth = 10
Columns("H:H").ColumnWidth = 16

Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
:="-", FieldInfo:=Array(1, 4), TrailingMinusNumbers:=True
Range("A3").Select

'Convert the fault stats from numbers to text descriptions
Call WordImport1_Loop
Call WordImport2_Loop
Call WordImport3_Loop
Call WordImport4_Loop
Call WordImport5_Loop
Call WordImport6_Loop
Call WordImport7_Loop
Call WordImport8_Loop
Call WordImport9_Loop
Call WordImport10_Loop
Call WordImport11_Loop
Call WordImport12_Loop

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Bootstrap 4: Exploring New Features

Learn how to use and navigate the new features included in Bootstrap 4, the most popular HTML, CSS, and JavaScript framework for developing responsive, mobile-first websites.

PC_BobCommented:

1.

Make wdFileName an argument for the sub ImportWordTable.
sub ImportWordTable(wdFileName as variant)

Open in new window

2.

Then change the call on ln 26 of the DirLoop sub to pass MyFile as the argument
ImportWordTable MyFile

Open in new window

3.

Lastly, comment out ln 13 in ImportWordTable.
0
vestanpance_ukAuthor Commented:
I followed your instructions to the letter PC_Bob, but it still didn't work... Just bypasses most of the looping sub...
No worries.. I got a solution.
Thanks again.
0
vestanpance_ukAuthor Commented:
I can't grade my own solution as excellent, because it's probably very convoluted but it works well and it does exactly what i want it to do: Open all word documents one by one from a specific folder and import the table to separate worksheets within an Excel workbook.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.