プロが教える店舗&オフィスのセキュリティ対策術

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

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

gooドクター

A 回答 (2件)

取りまとめるブック名を『統合.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

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

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

元ファイルは開くだけなので壊すことは無いと思いますが念の為です。
    • good
    • 1
この回答へのお礼

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

お礼日時:2008/06/24 21:06

良くある質問と思いますが、この質問タイトルは、後々他の方の役に立つ良い名前の付け方ですね。


方法1:人力で地道に行う
方法2:マクロで行う
過去に回答したコードを、特定の名前のシートだけコピーする様に変更しました。同じ名前のシートを複数コピーするので、ファイル名に付け替えています。新しいブックにではなく、このマクロのあるブックに収集します。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
    • good
    • 2
この回答へのお礼

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

お礼日時:2008/06/24 21:08

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング