VBA - 從特定文件夾打開文件並執行操作

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 <> ""循環的到來，但是從你正在努力實現裏面是什麼（複印件>>工作簿之間粘貼）。

裏面你的循環，你有太多的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筆記：

• .End(...)會得到錯誤的結果，如果有您的數據範圍的左邊或頂部邊框的空單元格。

• 上面是一個錯誤處理例程的簡單示例，使用僞try, catch, finally。確保你沒有創建任何無限循環（意思是：只有finally後執行的防彈代碼，並添加Exit Sub以上catch:

• 有極少的情況下使用.Copy和.PasteSpecial有道理

  。

  然而，在你的情況下，它保存到假設有更簡單，更快捷，更不能證明選項：

  • Range1.Value = Range2.Value，這一步寫入數據（因此它不是簡單地通過用戶交互，L擰IKE .Copy + .Paste是
  • 將數據讀入一個Array或更好的Recordset，它允許額外的處理，如用ADO.Connection和SQL，你猜對了其中，過濾掉空行
  • 拉的數據，甚至允許簡單的處理和犯規需要的工作簿

希望幫助的.Open + .Close和開關！