複数のエクセルブック・シートの内容を複写するマクロ

質問

エクセル2010を使っている者です。

「旅費計算」というフォルダに、「旅費計算（関東）、旅費計算（東北）、旅費計算（関西）・・旅費計算（愛知）等々たくさんのエクセルファイルが入っており、それぞれのファイルが１０枚以上のシートで構成されています。

新しいファイルを作って、当該フォルダ中の全てのファイル中の全てのシートのうちの３５行目から４５行目までをコピーして、一まとめにしたいと考えているのですが、そのようなことをする良い方法があったらお教えください。

VBAで記述すればなんとかなりそうな気もするのですが、お教えいただけると大変ありがたいです。

回答No.1

emaxemax · ベストアンサー

それではVBAの一例です。
それぞれの動きについてコメントもつけておきました。

Sub TEST()
　　Dim wb(1) As Workbook
　　Dim ws(1) As Worksheet
　　Dim myFdr As String, fn As String
　　Dim i As Long
　　With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定
　　　　If .Show = True Then
　　　　　　 myFdr = .SelectedItems(1)
　　　　Else
　　　　　　Exit Sub
　　　　End If
　　End With
　　i = 35
　　Application.ScreenUpdating = False '画面更新を一時停止
　　Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。
　　Set ws(0) = wb(0).Sheets(1) 'wb(0)の１枚目のシートをws(0)とする。
　　fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索
　　Do Until fn = Empty '全て検索
　　　　If fn <> wb(0).Name Then 'ブック名がこのブックの名前でなければ
　　　　　　Set wb(1) = Workbooks.Open(myFdr & "\" & fn) 'そのブックを開きwb(1)とする。
　　　　　　For Each ws(1) In wb(1).Worksheets 'wb(1)の各シートを
　　　　　　　　ws(1).Rows("35:45").Copy ws(0).Cells(i, "A") 'ws(0)にコピペ
　　　　　　　　i = i + 11
　　　　　　　　wb(1).Close (False) '有無を言わずに保存せず閉じる
　　　　　　Next '繰り返し
　　　　End If
　　　　fn = Dir 'フォルダ内の次のExcelブックを検索
　　Loop '繰り返す
　　Application.ScreenUpdating = True '画面更新停止を解除
End Sub

お礼

プログラムを書いていただいた上に、説明まで書いていただき、大変ありがとうございます。
勉強します。