[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『特定フォルダ内にある複数ファイルのシートを一つのファイルにまとめたい』(mika)
いつも参考にさせていただいております。
過去文書も検索しましたが該当の物がありませんでしたので、質問させていただきました。
特定のフォルダに入っている各ブックのシートを、全て新しいブックにコピーしたいのですが、どうしたらいいでしょうか。
*フォルダには約80個のブックがあります。(ブック名は全て異なります)
*各ブックの中にはシートが1つだけ存在します。(シート名は全て異なります)
*この各ブックの各シートを全て1つのファイル(80シートになるよう)にまとめたい
(なおリンク等はありませんが、シート内で完結する数式は入っています。)
こんなことができますでしょうか?
ご教示いただければ幸いです。よろしくお願い致します。
< 使用 Excel:Excel2010、使用 OS:Windows7 >
Sub test() Const cPATH = "c:\フォルダ名\" Dim cFiles As Variant Dim cFile As String Dim i As Long
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPATH & "*.xls*""").StdOut().ReadAll(), vbNewLine) For i = 0 To UBound(cFiles) - 1 cFile = LCase(Mid(cFiles(i), InStrRev(cFiles(i), "\") + 1)) If cFile <> LCase(ActiveWorkbook.Name) Then With Workbooks.Open(cFiles(i), False, True) .Sheets(1).Copy after:=Me.Parent.Sheets(Me.Parent.Sheets.Count) .Close False End With End If Next i End Sub
試していませんが、数式は元のブックを参照してしまいそうな気がします。値だけコピーする方が良いのでは?
(???) 2016/04/20(水) 18:06
上記コードで試しましたが、エラーになります。。
(Meキーワードの使用が不正です、とでます)
確かに数式ではなく値コピーの方がファイルも軽くなりますし良いですよね。
(mika) 2016/04/20(水) 18:19
失礼します。
(???)さんは、シートモジュールに記述する形式でコードをアップされることが多いです。 このコードを、任意のシートモジュールに記述して実行してみてください。
また、標準モジュールに記述するなら
.Sheets(1).Copy after:=Me.Parent.Sheets(Me.Parent.Sheets.Count)
これを
.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
にかえて試してみてください。
(β) 2016/04/20(水) 19:17
すでに (???)さんから、効率の良い DIRコマンドを使った例がアップされていますので参加目的だけで わりあいとよく使われる、DIR関数とFSOを使った例です。 フォルダは、デスクトップ上の "Test" というフォルダにしてあります。 (???)さんのコードはマクロブックにシートを取り込んでおられますが、以下のコードでは 新規ブックとして作成しています。
Sub Sample1() Dim fPath As String Dim fName As String Dim sh As Worksheet Dim nbk As Workbook
Application.ScreenUpdating = False
fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\Test\"
fName = Dir(fPath & "*.xlsx")
Do While fName <> "" Set sh = Workbooks.Open(fPath & fName, UpdateLinks:=False, ReadOnly:=True).Sheets(1) If nbk Is Nothing Then sh.Copy Set nbk = ActiveWorkbook Else sh.Copy after:=nbk.Sheets(nbk.Sheets.Count) End If sh.Parent.Close False fName = Dir() Loop
End Sub
Sub Sample2()
Dim fso As Object Dim file As Object Dim fPath As String Dim sh As Worksheet Dim nbk As Workbook
Application.ScreenUpdating = False
fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\Test" Set fso = CreateObject("Scripting.FileSystemObject")
For Each file In fso.GetFolder(fPath).Files If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then Set sh = Workbooks.Open(file.Path, UpdateLinks:=False, ReadOnly:=True).Sheets(1) If nbk Is Nothing Then sh.Copy Set nbk = ActiveWorkbook Else sh.Copy after:=nbk.Sheets(nbk.Sheets.Count) End If sh.Parent.Close False End If Next End Sub
(β) 2016/04/20(水) 20:39
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.