Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


14633 / 76734 ←次へ | 前へ→

【67590】Re:個々のファイルを開かずにマクロの実行
回答  UO3  - 10/12/16(木) 23:31 -

引用なし
パスワード
   ▼はるな さん:

こんばんは

各ブックのシートを、別ブックにコピーするのか、あるブックのあるシートを各ブックにコピーするのか
要件が理解できていませんので、とりあえず、前者で。はずしている確率、85%ぐらい?
勘違いしていたらすててください。

親ブックを作るとか、ボタンを配置するとか、それらは割愛しています。

指定フォルダの各エクセルブックのすべてのシートを1つのブックにまとめ まとめたブックを、
マクロブック名_作成.xls という名前で、マクロブックがあるフォルダに 保存します。
この間、各エクセルブックも、まとめたブックも表示されません。100個もブックがあると時間はかかると思いますが。
それと、シートの数が膨大になりますのでメモリーの関係で、悪名高い(?)1004のエラーが発生するかもしれません。

Sub Sample()
 Dim myPath As String
 Dim newWb As Workbook, workWB As Workbook
 Dim fsoFile As Object
 Dim sh As Worksheet
 Dim Fso As Object
 Dim xlApp As Excel.Application
 
 myPath = "C:\Test"  '<== 実際のフォルダ名に
 Set xlApp = New Excel.Application
 Set Fso = CreateObject("Scripting.FileSystemObject")
 
 For Each fsoFile In Fso.GetFolder(myPath).Files
  If LCase(Fso.GetExtensionName(fsoFile.Name)) = "xls" Then
   Set workWB = xlApp.Workbooks.Open(Filename:=myPath & "\" & fsoFile.Name)
   If newWb Is Nothing Then
    Set newWb = workWB
   Else
    For Each sh In workWB.Worksheets
     DoEvents
     sh.Copy after:=newWb.Sheets(newWb.Worksheets.Count)
    Next
    workWB.Close savechanges:=False
   End If
  End If
 Next
 
 Application.DisplayAlerts = False
 newWb.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_作成.xls"
 newWb.Close
 Application.DisplayAlerts = True
 
 xlApp.Quit
 
 MsgBox "処理が終了しました"
 
End Sub
0 hits

【67585】個々のファイルを開かずにマクロの実行 はるな 10/12/16(木) 17:25 質問
【67586】Re:個々のファイルを開かずにマクロの実行 UO3 10/12/16(木) 20:45 発言
【67587】Re:個々のファイルを開かずにマクロの実行 UO3 10/12/16(木) 20:59 発言
【67598】Re:個々のファイルを開かずにマクロの実行 はるな 10/12/17(金) 10:27 発言
【67597】Re:個々のファイルを開かずにマクロの実行 はるな 10/12/17(金) 10:12 発言
【67590】Re:個々のファイルを開かずにマクロの実行 UO3 10/12/16(木) 23:31 回答
【67601】Re:個々のファイルを開かずにマクロの実行 UO3 10/12/17(金) 12:20 回答
【67602】Re:個々のファイルを開かずにマクロの実行 UO3 10/12/17(金) 12:22 発言

14633 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free