Question

我想打开特定文件夹中的文件，并使用下面的代码执行操作。但是当VBA打开第一个文件时，它会停止。请帮帮我！

Sub ExtractData?()
    '
    ' ExtractData? Macro
    '
    ' Keyboard Shortcut: Ctrl+Shift+Q
    '
    Dim buf As String
    Dim dlg As FileDialog
    Dim fold_path As String



    Application.ScreenUpdating = False

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)

    If dlg.Show = False Then Exit Sub

    fold_path = dlg.SelectedItems(1)

    buf = Dir(fold_path & "\*.xlsx")

    Do While buf <> ""

        Workbooks.Open fold_path & "\" & buf


        Sheets("データセット1").Select
        Range("A2").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy

        Windows("Workbook.xlsm").Activate
        Sheets("GE").Select
        Cells(Range("A65536").End(xlUp).Row + 1, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Workbooks(buf).Close SaveChanges:=False
        buf = Dir()
    Loop

End Sub

Answer 1

错误不是来自您的Do While buf <> ""循环，而是来自您在内部尝试实现的内容（复制＆gt;＆gt;粘贴在工作簿之间）。

在你的循环中，你有太多Select，Selection和Activate，而是使用完全有资格的Range和Cells。

您可以使用With openWB.Worksheets("データセット1")，并在其下方使用.Range(.Cells(2, "A"), .Cells(LastRow, LastCol)).Copy嵌套您的范围。

代码

Sub ExtractData①()

' ExtractData? Macro
' Keyboard Shortcut: Ctrl+Shift+Q
'
Dim buf As String
Dim dlg As FileDialog
Dim fold_path As String
Dim openWB As Workbook
Dim LastRow As Long, LastCol As Long

Application.ScreenUpdating = False

Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
If dlg.Show = False Then Exit Sub

fold_path = dlg.SelectedItems(1)
buf = Dir(fold_path & "\*.xlsx")

Application.DisplayAlerts = False
Do While buf <> ""
    Set openWB = Workbooks.Open(fold_path & "\" & buf)  '<-- set open workbook to object

    With openWB.Worksheets("データセット1") '<-- not sure about this name (I don't have this font)
        ' set the range from A2 to last cell with data in sheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        .Range(.Cells(2, "A"), .Cells(LastRow, LastCol)).Copy
    End With

    ' if "Workbook.xlsm" is this workbook with the code, could be repalced with ThisWorkbook
    With Workbooks("Workbook.xlsm").Worksheets("GE")
        .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, _
                                                        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With

    openWB.Close False
    buf = Dir()
Loop

' restore settings
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Answer 2

虽然您的代码适合我，但使用Select，Selection和Activate非常容易出错，尤其是在循环中使用或在多个工作簿中使用时。

使用嵌套的With Objects可以使其更安全，更快速，更易读，而不会强迫您使用Dim和Set大量的对象变量。试试这个：

On Error Goto catch:
try:
With Workbooks.Open(fold_path & "\" & buf)

    With .Sheets("データセット1").Range("A2")
        Range(.Cells(1, 1).End(xlToRight), .End(xlDown)).Copy
    End With

    With ThisWorkbook.Sheets("GE")
        .Cells(Range("A65536").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End With
finally:            
    .Close SaveChanges:=False
End With

' rest of your code

Exit Sub

catch:
Debug.Print "Err at File " & buf & vbCrLf & Err & vbTab & Error
GoTo finally

Addidional notes：

.End(...)会得到错误的结果。
上面是一个使用伪try, catch, finally的错误处理例程的简单示例。确保您不创建任何无限循环（意思是：仅在finally后执行防弹代码并在Exit Sub

catch:

在极少数情况下使用.Copy和.PasteSpecial是有道理的。

但是，在您的情况下，可以假设存在更简单，更快速和更多故障证明选项：
- Range1.Value = Range2.Value，它一步编写数据（因此，.Copy + .Paste不会像用户互动那样简单地搞错了
- 将数据读入Array或更好的Recordset，这样可以进行额外的处理，例如过滤掉空行
- 使用ADO.Connection和SQL提取数据，您猜对了，它允许更简单的处理，不需要.Open + .Close并在工作簿之间切换

希望有所帮助！

VBA - 从特定文件夹打开文件并执行操作

2 个答案: