VBA - 特定のフォルダからファイルを開き、処理を実行します。

Question

特定のフォルダからファイルを開き、以下のコードで処理します。 しかし、VBAが最初のファイルを開くと、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 <> ""ループから、しかし、あなたが内側（ワークブック間のコピー>>ペースト）を達成しようとしているものから来ていません。あなたのループ内

、あなたの代わりに、完全にqualifed RangeとCellsを使用し、Select、SelectionとActivateあまりにも多くを持っています。

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を使用したエラー処理ルーチンの簡単な例です。意味（あなたが任意の無限ループを作成しないことを確認します。のみ.Copyと.PasteSpecialの使用は理にかなっているまれなケース

  があるfinally後防弾のコードを実行し、Exit Sub

catch:の上を追加

しかし、あなたの場合には、それはより速く、より単純があることを前提とし、より多くの証拠の選択肢が失敗し、セーブ：ワンステップでデータを書き込み

• Range1.Value = Range2.Valueを、（そのためには、単にユーザーとの対話、Lでねじ込まれていませんIKE .Copy + .Pasteは、あなたがそれを推測し、ADO.ConnectionおよびSQL、と
• プルデータを空の行をフィルタリングするように、追加的な処理を可能にする、Arrayまたはより良いRecordsetにデータを読む
• であっても単純処理とdoesntのを可能に.Open + .Closeとワークブック

の切り替え希望助けを必要とします！