CODEWITHSUNDEEP
excelvba
DavenIT
DavenIT

Reputation: 3

Excel VBA need help processing multiple files in folder

I only have basic Excel VBA knowledge, I need some help to adapt the code to process all .docx in a directory. I have adapted some Excel VBA code I found here to open a word document and copy table data to the spreadsheet. It then copies that data to a new line in a worksheet. This all works fine for a single file, however I am not sure how to adapt this to process through all .docx files in a specified folder (300+). Any help or suggestions will be greatly appreciated.

Sub ImportWordTableWorking()
'Import Word table into Excel and paste in new row

Dim ws As Object
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim lastrow As Long


wdFileName = Application.GetOpenFilename("Word files (*.docx),*.doc", , _
"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

'write filename to sheet

Cells(2, 9) = wdFileName
Sheets("GrabData").Select

With wdDoc
    If wdDoc.Tables.Count = 0 Then
        MsgBox "This document contains no tables", _
            vbExclamation, "Import Word Table"
    Else
        jRow = 0
       Set ws = Worksheets("Invoice-Import")
       Sheets("Invoice-Import").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
        For TableNo = 1 To wdDoc.Tables.Count
            With .Tables(TableNo)
'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    jRow = jRow + 1
                    For iCol = 1 To .Columns.Count
                        On Error Resume Next
                        ActiveSheet.Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        On Error GoTo 0
                    Next iCol
                Next iRow
            End With
            jRow = jRow + 1
        Next TableNo
    End If
End With

'Çopy and paste selection as values in last row of GL sheet
        Sheets("GrabData").Range("A2:J2").Copy
        Sheets("GL").Activate
lastrow = Range("A65536").End(xlUp).Row
Sheets("GL").Activate
Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Set wdDoc = Nothing
End Sub

OK, sorry for my ignorance, I have tried adjusting the code to refer to strFile instead for wdDoc but I am getting and error "Object must be defined" from With strFile see new code:

Sub G()

   Dim r&
    Dim strFile$, strFolder$

    strFolder = "C:\Temp\"
    strFile = Dir(strFolder) '//First file

    While Not strFile = ""

        '// Next row in Excel file
        r = r + 1

        strFile = strFolder + strFile

'Import Word table into Excel and paste in new row

Dim ws As Object
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim lastrow As Long


''wdFileName = Application.GetOpenFilename("Word files (*.docx),*.doc", , _
''"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

'write filename to sheet

Cells(2, 9) = strFile
Sheets("GrabData").Select

With strFile
    If strFile.Tables.Count = 0 Then
        MsgBox "This document contains no tables", _
            vbExclamation, "Import Word Table"
    Else
        jRow = 0
       Set ws = Worksheets("Invoice-Import")
       Sheets("Invoice-Import").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
        For TableNo = 1 To strFile.Tables.Count
            With .Tables(TableNo)
'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    jRow = jRow + 1
                    For iCol = 1 To .Columns.Count
                        On Error Resume Next
                        ActiveSheet.Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        On Error GoTo 0
                    Next iCol
                Next iRow
            End With
            jRow = jRow + 1
        Next TableNo
    End If
End With

'Çopy and paste selection as values in last row of GL sheet
        Sheets("GrabData").Range("A2:J2").Copy
        Sheets("GL").Activate
lastrow = Range("A65536").End(xlUp).Row
Sheets("GL").Activate
Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Set strFile = Nothing

        strFile = Dir() '// Fetch next file in a folder

    Wend

End Sub

Thanks in advance PD

Many thanks Johny,

You are a guru. After some sleep and further debugging I found the issue was my code was referring to wddoc (open word document filename) which I realised was expecting an object not a string. After using Set wdDoc = GetObject(strFile) it fixed the undefined object type issue and it all started working. My only other question is how to limit it to only open .docx? Here is the working code:

Sub ImportWordInvoice()

Dim r&
Dim strFile$, strFolder$
Dim ws As Object
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim lastrow As Long


 strFolder = "C:\testmacro\Invoices\"
    strFile = Dir(strFolder) '//First file
    While Not strFile = ""
        strFile = strFolder + strFile

        Set wdDoc = GetObject(strFile)

'write filename to static cell
Sheets("GrabData").Select
Cells(2, 9) = strFile

With wdDoc
    If wdDoc.Tables.Count = 0 Then
        MsgBox "This document contains no tables", _
            vbExclamation, "Import Word Table"
    Else
        jRow = 0
       Set ws = Worksheets("Invoice-Import")
       Sheets("Invoice-Import").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
        For TableNo = 1 To wdDoc.Tables.Count
            With .Tables(TableNo)
'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    jRow = jRow + 1
                    For iCol = 1 To .Columns.Count
                        On Error Resume Next
                        ActiveSheet.Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        On Error GoTo 0
                    Next iCol
                Next iRow
            End With
            jRow = jRow + 1
        Next TableNo
    End If
End With

'Çopy and paste selection as values in last row of GL sheet
        Sheets("GrabData").Range("A2:J2").Copy
        Sheets("GL").Activate
lastrow = Range("A65536").End(xlUp).Row
Sheets("GL").Activate
Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Set wdDoc = Nothing

        strFile = Dir() '// Fetch next file in a folder

    Wend
MsgBox "Complete"
End Sub

Thanks once again, now I don't need to double entry all my wife's word invoices into a spreadsheet. I really appreciate your time and knowledge.

Regards

PD

Upvotes: 0

Views: 540

Answers (1)

JohnyL
JohnyL

Reputation: 7162

You can use Dir() function. The main idea is following:

Sub G()

    Dim r&
    Dim strFile$, strFolder$

    strFolder = "C:\Temp\"
    strFile = Dir(strFolder) '//First file

    While Not strFile = ""

        '// Next row in Excel file
        r = r + 1

        strFile = strFolder + strFile

        '// Write down file name (into column A).
        '// If you need only file name, the put this line
        '// before "strFile = strFolder + strFile"
        Cells(r, "A") = strFile

        '// Do your things...

        strFile = Dir() '//Fetch next fille

    Wend

End Sub

Upvotes: 1

Related Questions