Question

我只有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

好的，很抱歉，我无知，我尝试调整代码以引用wdDoc的strFile，但是我得到了并且错误“必须定义对象”来自于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（打开的Word文档文件名），我意识到这是在期望对象不是字符串。使用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

再次感谢，现在我不需要将我妻子的所有单词发票重复输入电子表格中。非常感谢您的时间和知识。

致谢

PD

Answer 1

您可以使用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

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

1 个答案: