Excel VBA需要帮助处理文件夹中的多个文件

我只有基本的Excel VBA知识，我需要一些帮助来调整代码以处理目录中的所有.docx。 我在这里找到了一些Excel VBA代码，用于打开word文档并将表格数据复制到电子表格中。然后将该数据复制到工作表中的新行。对于单个文件来说，这一切都很好，但是我不确定如何通过指定文件夹（300+）中的所有.docx文件来处理这一切。任何帮助或建议都将不胜感激

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

好的，很抱歉我不知道，我已经尝试调整代码以引用strFile而不是wdDoc，但我从strFile中得到错误“必须定义对象”请参见新代码：

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

提前谢谢 PD

非常感谢约翰

你是一位大师。经过一些睡眠和进一步调试后，我发现问题在于我的代码引用了wddoc（open word document filename），我意识到它应该是一个对象而不是字符串。使用

Set wdDoc=GetObject（strFile）

后，它修复了未定义的对象类型问题，并开始工作。我唯一的另一个问题是如何将它限制为只打开.docx？ 以下是工作代码：

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

再次感谢，现在我不需要在电子表格中重复输入我妻子的所有word发票。我真的很感谢你的时间和知识

问候

PD

您可以使用

Dir（）

函数。主要思想如下：

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

---

非常感谢Johny，我如何在代码中引用当前文件名？我正在将文件名写入单元格。谢谢，我将尝试将对wdDoc的引用替换为strFile。就我个人而言，我更喜欢用“&”符号连接两个字符串：

strFile=strFolder&strFile

。Cf..@T.M.这个案例是安全的：）我用新代码编辑了原始问题，很抱歉我有点困惑，因为我相信你会看到我的代码…如果你愿意，我们可以在Skype中讨论你的问题：）