スキルアップ・問題解決なら、モーグにおまかせ！

お忙しいところ大変恐縮ですが、お教え頂ければ幸いです。
 
約50個のエクセルブックがあります。そして、それぞれのブックの名称は、部署名（例：総務課、税務課など）となっています。また、それぞれのブックには、約50個のシートがあり、シート名はブックと同じ部署名が約50個記載されています。
遣りたいこと（教えて頂きたいこと）は、ブックの名称と同じシートをコピーし、新規のブックを作成しそこに約50シートを貼り付けて保存する方法です。
 
よろしくお願いいたします。

内容の確認

引用:

それぞれのブックには、約50個のシートがあり、シート名はブックと同じ部署名が約50個記載されています

追加レス
 
実際の例（実在する部署名でなくてもよい）で
具体的な説明をお願いします。
 

引用:
それぞれのブックには、約50個のシートがあり、
シート名はブックと同じ部署名が約50個記載されています。

引用:
約50個のエクセルブックがあります。そして、それぞれのブックの名称は、
部署名（例：総務課、税務課など）となっています。

引用:
ブックの名称と同じシートをコピーし、新規のブックを作成し
そこに約50シートを貼り付けて保存する方法

お世話になっております。
 
私の説明が拙くて大変申し訳ございません。
私がしようとしていることは、sk様が説明していただいたとおりです。
 
今は手作業でブックを一つ一つ開いてシートのコピーをしているのですが、
少しでも業務の効率化が図れないものかと検討しているところです。
 
よろしくお願いいたします。

参考コードを掲示します。
50x50回分のファイルを開くので、画面のちらつき等、操作性はよくありません。
 
不具合は、適宜修正してください。
 

Option Explicit

Sub Sample()
Dim FTBL, FS, FX As Long, Tx As Long
Dim myPATH As String, F

    '対象ファイル取得⇒パス配列へ格納
    myPATH = "D:\新しいフォルダー"
    With CreateObject("Scripting.FileSystemObject")
        Set FS = .Getfolder(myPATH).Files
        ReDim FTBL(1 To FS.Count)
        Tx = 0
        For Each F In FS
            Tx = Tx + 1
            FTBL(Tx) = F.Path
        Next
    End With
    
Dim wbk As Workbook, NewBook As Workbook
Dim wSht As Worksheet
Dim FXX As Long, FX1 As Long

    For FX = LBound(FTBL) To UBound(FTBL)
        Set wbk = Workbooks.Open(Filename:=FTBL(FX))
        With wbk
            For Each wSht In .Worksheets
                If wSht.Name = Left(.Name, InStr(wbk.Name, ".") - 1) Then
                    wSht.Copy
                    Set NewBook = ActiveWorkbook
                    FXX = FX
                    Exit For
                End If
            Next
            .Close False
        End With
        GoSub FilePUT
        Set NewBook = Nothing
    Next
    Exit Sub

FilePUT:
    For FX1 = LBound(FTBL) To UBound(FTBL)
        If FX1 <> FXX Then
            Set wbk = Workbooks.Open(Filename:=FTBL(FX))
            For Each wSht In wbk.Sheets
                If wSht.Name = NewBook.Sheets(1).Name Then
                    wSht.Copy after:=NewBook.Sheets(NewBook.Sheets.Count)
                    wbk.Close False
                    Exit For
                End If
            Next
        End If
    Next
    NewBook.SaveAs Filename:=myPATH & "\NEW_" & NewBook.Sheets(1).Name & ".xlsX"
    NewBook.Close False
    Return
End Sub

既に回答いただいていますが、別の書き方も挙げておきます。
 

Sub main()
    Dim newBook As Workbook
    Dim myPATH   As String
    Dim f        As Object
    Dim wb       As Workbook
    Dim baseName As String
    '50個のブックを順次開き、ブック名と同じ名前を持つシートを、
    '新規作成ブックにコピーする
    
    '新規ブックの作成
    Set newBook = Workbooks.Add

    myPATH = "D:\フォルダー"   ' 50個のブックがあるフォルダ
    
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .Getfolder(myPATH).Files
            Set wb = Workbooks.Open(f.Path)
            baseName = .GetBaseName(f.Path)     '拡張子を除くファイル名
            wb.Worksheets(baseName).Copy _
                    after:=newBook.Worksheets(newBook.Worksheets.Count)
            wb.Close False
        Next
    End With
    '集約したブックを保存
    newBook.SaveAs "結果.xlsx", xlWorkbookDefault
End Sub

ウィンアロー 様
シンプル　様
 
おはようございます。
大変お世話になっております。
 
お教えいただき大変ありがとうございます。
ＶＢＡについては、未だそれほど詳しくありませんが、自分でコードを書いて
やってみたいと思います。
 
その結果については、改めてご報告したいと思います。

参考のコードをアップしてから気が付いたのですが、
  
例えば、複数のブックに「総務課」というシートが存在しているわけ
（５０ブックあるとしたら、５０シートになりますよね）
ですが、
「５０シートを１つのブックに集める」という考えで
コードを作成しましたが、「全て、同一の内容だったら？」
・・・・それでよいのかな？
という疑問がわいてきました。
  
「総務課」ブックには、「総務課」シートだけ
ということならば、他のシートを削除してしまえばよいのだで、
仕様がもっとすっきりします。
別名で保存するかは、別の話です。
  
質問者さんへ、
  
仕様をもっと具体的にしないと、空振りになる可能性があります。
 

いまさらですが
>自分でコードを書いてやってみたいと思います。
 
コードに取り掛かる前にシステムの仕様を明確にしましょう。
 
勝手な推測で書きますが、
 
 
Ａの場面
「統合ファイル」：部署別シートが５０シート
から、部署別ブックを作成したい
⇒部署別ブックには、当該部署のシートのみを入れる
⇒各部署の担当者が更新する
 
Ｂ場面
各部署で更新したファイルを受取り
部署別ファイル（ブック）を統合ファイル（ブック）に集約（複写）する
この統合ファイル用途は省略
 
ある周期でＡ場面とＢ場面を繰り返す
 
という想定をした場合、今回の話は、Ａ場面であると考えます。
説明の中では、統合ファイルが部署の数だけ存在しているように書いているが、
果たしてそうなのか疑問である。
 
若し、部署の数だけ統合ファイルを複写（含む、名前変更）しているならば、
無駄かもしれません、名前変更でミス入力することも考えられます。
ブック名と同一のシート名が成り立たなくなります
 
以上は、私の私見ですので、
もう一度、仕様を確認してみてください。
 
 

WinArrow　様
 
お世話になっております。よろしくお願いいたします。
 
改めて仕様というか遣りたいことについて整理してみました。
 
「業務進捗確認（取りまとめ用）」があり、部署別シートが50シートあります。
半年に1回程度、各部署に業務進捗の報告をしてもらいます。
その方法は、各部署に「業務進捗確認（確認用）」を送付し、自分たちの部署
シートに業務の進捗状況を記載し報告してもらっています。
※業務進捗確認（確認用）の中身は、業務進捗確認（取りまとめ用）と一緒です。
※各部署からの回答の際のファイル名称は、「【02_総務課】業務進捗確認
（確認用）」のように先頭に【02_部署名】が付くことになっています。
 
 
今回遣りたいことは、各部署から届いた進捗の報告内容のとおり、「業務進捗確認
（取りまとめ用）」のシートを上書き更新したいということです。
 
よろしくお願いいたします。

WinArrow　様
 
お世話になっております。よろしくお願いいたします。
 
改めて仕様というか遣りたいことについて整理してみました。
 
「業務進捗確認（取りまとめ用）」があり、部署別シートが50シートあります。
半年に1回程度、各部署に業務進捗の報告をしてもらいます。
その方法は、各部署に「業務進捗確認（確認用）」を送付し、自分たちの部署
シートに業務の進捗状況を記載し報告してもらっています。
※業務進捗確認（確認用）の中身は、業務進捗確認（取りまとめ用）と一緒です。
※各部署からの回答の際のファイル名称は、「【02_総務課】業務進捗確認
（確認用）」のように先頭に【02_部署名】が付くことになっています。
 
 
今回遣りたいことは、各部署から届いた進捗の報告内容のとおり、「業務進捗確認
（取りまとめ用）」のシートを上書き更新したいということです。

整理して頂き、話が見えるようになってきました。
 
「02_部署名・・・.xlsx」の中にも他部署のシートがあるということですね？
 
参考コード（動作確認はしてありません）
 

Sub sample()
Dim FileTBL, Fx As Long, F
Dim myPATH As String, NewBook As Workbook
Dim sht As Worksheet, shtnm, Sx As Long

    myPATH = "D:\確認用フォルダー"
    ReDim FileTBL(1 To 1): Fx = 0
    With CreateObject("Scripting.FileSystemObject")
        For Each F In .Getfolder(myPATH).Files
            If Left(F.Name, 3) = "02_" Then
                Fx = Fx + 1
                ReDim Preserve FileTBL(1 To Fx)
                FileTBL(Fx) = F.Path
            End If
        Next
    End With

    Set NewBook = Workbooks.Add
    ReDim shtnm(1 To 1): Sx = 0
    For F = LBound(FileTBL) To UBound(FileTBL)
        With Workbooks.Open(Filename:=FileTBL(Fx))
            For Each sht In .Sheets
                If .Name Like "*" & sht.Name & "*" Then
                    sht.Copy after:=NewBook.Sheets(NewBook.Sheets.Count)
                    Sx = Sx + 1
                    ReDim Preserve shtnm(1 To Sx)
                    shtnm(Sx) = sht.Name
                    Exit For
                End If
            Next
            If sht Is Nothing Then
                MsgBox "「ブック名」（" & .Name & "」に対応するシートは存在しません"
            End If
            .Close False
        End With
    Next
'    With NewBook.Sheets(1)
'        .Name = "目次"
'
'    End With
    NewBook.SaveAs Filename:=myPATH & "\取り纏め用.xlsx"
    NewBook.Close False
    Set NewBook = Nothing
End Sub

現状は、その業務フローなのでしょうが、それを見直した方がすっきりしませんでしょうか。
 
1）「業務進捗確認（取りまとめ用）」の各シートを 1ファイルとして作成する(VBAで)
 
2)　作成したファイルを 各部署に配布し、回答してもらう
 
3） 回答された複数ファイルの シートを 1ブックにまとめる
 
 
この方が、各部署で記入する際の間違いを減らせますし
まとめる際にも、 既存シート を削除する 事を意識せずに済むと思います。
 
 
サンプルです。
 

Sub シート個別ファイル保存()
  Dim wbk As Workbook
  Dim wst As Worksheet

  Dim TargetFile As Variant
  Dim TargetFolder As Variant

  With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "対象ファイルを選択"
    If .Show = True Then
      TargetFile = .SelectedItems(1)
    End If
  End With
  If TargetFile = "" Then Exit Sub

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "保存先フォルダを指定"
    If .Show = True Then
      TargetFolder = .SelectedItems(1)
    End If
  End With
  If TargetFolder = "" Then Exit Sub

  Set wbk = Application.Workbooks.Open(TargetFile, , True)
  For Each wst In wbk.Worksheets
    wst.Copy
    With ActiveWorkbook
      .SaveAs TargetFolder & "\" & wst.Name, xlWorkbookDefault
      .Close
    End With
  Next

  wbk.Close
  Set wst = Nothing
  Set wbk = Nothing
End Sub


Sub ファイル統合()
  Dim wbk0 As Workbook
  Dim wbk1 As Workbook

  Dim FSO As Object 'Scripting.FileSystemObject
  Dim Fil As Object 'Scripting.File

  Dim i As Long

  Dim TargetFile As Variant
  Dim TargetFolder As Variant

  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "保存されているフォルダを選択"
    If .Show = True Then
      TargetFolder = .SelectedItems(1)
    End If
  End With
  If TargetFolder = "" Then Exit Sub

  Set FSO = CreateObject("Scripting.FileSystemObject")

  For Each Fil In FSO.GetFolder(TargetFolder).Files
    If FSO.GetExtensionName(Fil.Path) = "xlsx" Then
      i = i + 1
      Set wbk1 = Workbooks.Open(Fil.Path, , True)
      If i = 1 Then
        wbk1.Worksheets.Copy
        Set wbk0 = ActiveWorkbook
      Else
        wbk1.Worksheets.Copy After:=wbk0.Worksheets(wbk0.Worksheets.Count)
      End If
      wbk1.Close
    End If
  Next

  Stop

  wbk0.SaveAs TargetFolder & "\" & "保存ファイル名.xlsx"
  wbk0.Close

  Set wbk1 = Nothing
  Set wbk0 = Nothing
End Sub

WinArrow　様
 
デスクトップに「取り込み」というファイルを作成し、その中に各課からの回答ファイルを３つ入れて、教え頂いたコードを試してみました。
３つのファイルは、（02_【総務課】●●●、02_【税務課】●●●、02_【福祉課】●●●）のようになっています。
コードを実行すると「取り纏め用」ファイルが作成されましたが、中身を見て見ると、sheet1の右側に総務課その隣に総務課(1)その隣に総務課(2)となっており、税務課、福祉課のデータは取り込まれておりません。コードをじっくり見ながら何処を修正したらよいか考えていますが、なかなか分からない状況です。
 
取り急ぎご報告まで。
 
Suzu　様
 
未だ教えていただいたコードを試せておりませんのえ、確認後に改めてご報告をさせていただければと
考えています。よろしくお願いいたします。
 
[/quote]

申し訳ありません。
コードを一部修正してください。
誤）
> For F = LBound(FileTBL) To UBound(FileTBL)
↓
 
,正)
 
    For Fx = LBound(FileTBL) To UBound(FileTBL)

WinArrow　様
 
こんばんは。
 
教えた頂いたコードを記述すると私がやりたいことを実施することができました！
本当にありがとうございました。
コードの内容は分からない部分もありますが、先ずは自分で調べながら勉強していきたいと思います。
 
Suzu　様
 
教えた頂いたコードについては、未だ確認できておりませんが、私が遣りたいことは達成できましたので、この質問については解決とさせていただきたいと思います。
お忙し中、ご教示いただいたことに深く感謝します。ありがとうございました。
教えていただいたコードについては、必ず試しにやってみます。その際に、ご教示いただく事がでてくるかもしれませんが、その際は何卒宜しくお願い致します。
 
その他の皆様におかれても色々とお教えいただき本当にありがとうございました。