[[20190308135638]]　『複数ブックから指定シートを取り込む』（がんばる事務員）　ページの最後に飛ぶ

『複数ブックから指定シートを取り込む』（がんばる事務員）

いつもお世話になっております。

下記のマクロがあるのですが、
取り込みたいシート名が完全一致していないとエラーになります。

たとえば取り込みたいシートが下記の通りブックによって月が変わっている場合、「内訳」という名前を含むシートだけを抽出したいです。
　
book1　シート名「4月内訳」
book2　シート名「5月内訳」
book3　シート名「6月内訳」

そのようなことは可能でしょうか。

Sub すべてのブックから指定シートを取り込む()

'オブジェクトを設定する
Set ファイルシステム = CreateObject("Scripting.FileSystemObject")

'指定するシート名を取り込む
対象シート = Cells(1, 1).Text

'読み込むファイルを1個指定する
あるブック = Application.GetOpenFilename("Excelファイル(*.xlsm),*.xlsm")

'親フォルダーを取得する
Set 親フォルダー = ファイルシステム.GetFile(あるブック).ParentFolder

'親フォルダー内の全ファイルに以下の操作をする
For Each ファイル In 親フォルダー.Files

    'ファイルを開く
    Workbooks.Open ファイル.Path

    'ブック名を記憶する
    ブック名 = ActiveWorkbook.Name

    '開いたファイルの対象シートを右端シートの後ろにコピーする
    ActiveWorkbook.Worksheets(対象シート).Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

    '開いたファイルを閉じる
    Workbooks(ブック名).Close SaveChanges:=False

    'シート名を変更する
    ThisWorkbook.Worksheets(対象シート).Name = 対象シート + ファイル.Name

Next
End Sub

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

こんにちは。

 >そのようなことは可能でしょうか。

 可能ですが、それぞれのブックの全シートの名前を
 総当たりで調べないといけないです。

（でれすけ） 2019/03/08(金) 15:21

 Sub すべてのブックから指定シートを取り込む()
   Dim Path As String, FSO As Object, File As Object
   Dim WB As Workbook, WS As Worksheet, WSs As Sheets
   Dim sheetName As String

   Path = getFolderPath()
   If Path = "" Then Exit Sub

 ' sheetName = Cells(1, 1).Text
   sheetName = "*内訳*"

   Set FSO = CreateObject("Scripting.FileSystemObject")

   For Each File In FSO.GetFolder(Path).Files
       If File.Name Like "*.xlsx" Then
          Set WB = Workbooks.Open(File.Path, ReadOnly:=True)
          Set WSs = GetSheetsByName(WB, sheetName)
          If Not WSs Is Nothing Then
             For Each WS In WSs
                 With ThisWorkbook
                    WS.Copy After:=.Worksheets(.Worksheets.Count)
                    ChangeSheetName .Worksheets(.Worksheets.Count), WS.Name & "_" & WB.Name
                 End With
             Next
          End If
          WB.Close SaveChanges:=False
       End If
   Next

   Set FSO = Nothing

 End Sub

 Function getFolderPath() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show = True Then
          getFolderPath = .SelectedItems(1)
      Else
          Path = ""
      End If
    End With
 End Function

 Function GetSheetsByName(WB As Workbook, strName As String) As Sheets
    Dim WS As Worksheet
    Dim WS_index() As Integer, i As Integer, n As Integer
    i = 1: n = 0:
    ReDim WS_index(1 To WB.Worksheets.Count)
    For Each WS In WB.Worksheets
       If WS.Name Like strName Then
          n = n + 1
          WS_index(n) = i
       End If
       i = i + 1
    Next
    If n = 0 Then
       Set GetSheetsByName = Nothing
    Else
       ReDim Preserve WS_index(1 To n)
       Set GetSheetsByName = WB.Worksheets(WS_index)
    End If
 End Function

 Sub ChangeSheetName(WS As Worksheet, ByVal newName As String)
    Dim i As Integer, n As Integer
    Dim oWS As Worksheet
    n = 1
    On Error GoTo Err_NewName
       WS.Name = newName
    On Error GoTo 0
    Exit Sub

 Err_NewName:
       If n > 99 Then Err.Raise Err.Number, , Err.Description
       Set oWS = WS.Parent.Worksheets(newName)
       If oWS.Name Like "*(?)" Or WS.Name Like "*(??)" Then
          i = InStrRev(oWS.Name, "(")
          n = Val(Mid(oWS.Name, i + 1)) + 1
          newName = Left(oWS.Name, i) & n & ")"
       Else
          n = n + 1
          newName = newName & Format(n, "(0)")
       End If
       Resume
 End Sub

（でれすけ） 2019/03/08(金) 16:10

でれすけ様

返信遅くなり申し訳ございません。
ご回答ありがとうございます！！
まだまだ勉強不足で作成頂いたマクロを良く理解できておりません；；

まずは動かしてみて、どのような動きをするのか確認してみたいと思います。

不明な点があればまた質問させてください！！
（がんばる事務員） 2019/03/11(月) 16:59

 こんにちは。
　
 動かしてみて、所望の動きをしているかどうかをまずお知らせください。

（でれすけ） 2019/03/11(月) 17:52

でれすけ様

さっそく動かしてみたところ、思い通りの動きでした！！！
シート名の名前が完全一致でないものが多い為、とても助かります。

作成して頂いたマクロ、一つ一つ勉強したいと思います。

ちなみになんですが、
私が提示したマクロを少し修正しただけでは　でれすけ様が作成したようなマクロはできないですよね？
後々のメンテナンスを考えると簡単に修正できればなぁと思ったのですが。。。

（がんばる事務員） 2019/03/12(火) 13:30

 >私が提示したマクロを少し修正しただけでは　でれすけ様が作成したようなマクロはできないですよね？

 ならないですね。

 基本的考え方は、最初に書いたように、総当たりで調べる必要があります。

 開いたブックの全てのシートを For ～ Next か For Each ～ Next でループします。
 シート名の比較は、今回の場合は、Like演算子を使うと便利だと思います。

 上記を踏まえて元々のマクロ修正してみてはどうでしょうか。

 私の提示したものは、いろいろ余計なことをしています。

 余計なこと(しなくても今回の問題解決に関係のないもの)
   [1]フォルダの指定方法を変更した。(getFolderPath)
      ブックを指定してそのファイルのフォルダを調べるのが回りくどいと思ったから

   [2]ブックのシート名を総当たりで調べる処理をサブプロシジャ(GetSheetsByName)に追い出した。
      複数シートが該当したら、Sheetsコレクションオブジェクトを返すようにした。

   [3]シート名の名称変更処理をサブプロシジャ(ChangeSheetName)に追い出した。
      変更しようとするシート名がすでにあるとエラーになるので、エラー処理を組み込みたかった

 ということなんですが、上記の３つのサブプロシジャは、
 今回作ったのではなく、昔作ったやつの使い回しです。
 汎用的に使えるサブプロシジャを作りためておくと、後で便利ですよ。

（でれすけ） 2019/03/12(火) 14:20

でれすけ様

なるほど、アドバイスありがとうございます。
Like演算子は使ったことがないのでよく調べてみます。

使えるサブプロシジャ私も少しですが貯めております。。（本当に簡単なものですが；；）

昔作ったやつを組み込んだりすのも今の私には難しいです。
覚えることがまだまだあります；；
また何かありましたら質問させてください！

（がんばる事務員） 2019/03/12(火) 15:39

コメント返信：

[ 一覧(最新更新順) ]

[[20190308135638]] 『複数ブックから指定シートを取り込む』（がんばる事務員） ページの最後に飛ぶ

[[20190308135638]]　『複数ブックから指定シートを取り込む』（がんばる事務員）　ページの最後に飛ぶ