複数ファイルから特定シートのコピー

質問

同じフォルダ内に、エクセルファイルがいくつかあります。
そのフォルダ内のファイルから、特定のシート名（例：シートA)のシートをコピーしシートAだけの新しいファイルとして作成しようと思います。

シートAを含むファイルは複数あります。
何か方法がありましたらご教授お願いいたします。

回答No.2

keirika · ベストアンサー

取りまとめるブック名を『統合.xls』とします。

Sub Sample()
On Error Resume Next

Dim TSheet As String
TSheet = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)
Do While TSheet <> ""
If TSheet <> "統合.xls" Then
Workbooks.Open (ThisWorkbook.Path & "\" & TSheet)
ActiveWorkbook.Sheets("シートA").Copy after:= _
Workbooks("統合.xls").Sheets(1)
Workbooks(TSheet).Close
End If
TSheet = Dir()
Loop
End Sub

必要な箇所は適宜変更して下さい。

また、実行する際はフォルダのバックアップは必ず取ってください。

元ファイルは開くだけなので壊すことは無いと思いますが念の為です。

お礼

keirikaさん、どうもありがとうございます。
望んでいたものとドンピシャです！

回答No.1

mitarashi

良くある質問と思いますが、この質問タイトルは、後々他の方の役に立つ良い名前の付け方ですね。
方法１：人力で地道に行う
方法２：マクロで行う
過去に回答したコードを、特定の名前のシートだけコピーする様に変更しました。同じ名前のシートを複数コピーするので、ファイル名に付け替えています。新しいブックにではなく、このマクロのあるブックに収集します。XL2000のコードです。
Sub treatAllFiles()
Dim FSO As Object
Dim folderName As String
Dim targetFolder As Object
Dim targetFiles As Object
Dim targetFile As Object
Dim sh As Worksheet

'フォルダー名は環境に合わせる事
folderName = "C:\Documents and Settings\?????\My Documents\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set targetFolder = FSO.getfolder(folderName)
Set targetFiles = targetFolder.Files
For Each targetFile In targetFiles
DoEvents '途中でやめたくなった時のための保険
If UCase(Right(targetFile, 4)) = ".XLS" Then
Application.Workbooks.Open Filename:=targetFile, UpdateLinks:=False
For Each sh In Application.ActiveWorkbook.Worksheets
If sh.Name = "特定のシート名" Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = FSO.GetBaseName(targetFile)
End If
Next
Windows(FSO.GetFileName(targetFile)).Activate
Call ActiveWorkbook.Close(savechanges:=False)
End If
Next targetFile
End Sub

お礼

mitarashiさん
希望していた通りの結果になりました。
ありがとうございます！
タイトルをお褒めいただき恐縮です。