ブックを開いて閉じるＶＢＡ

質問

初めまして、ブックを開いて閉じるループのＶＢＡについて質問させてください！

別添の画像のようなブックＡの中に、「りんご」のように名前のついたシートが複数あります。（この数は変動します。来月は「ぶどう」が入るかもしれないし、「りんご」がなくなるかもしれません。）

そして「新しいフォルダ」という名前のフォルダに、別添の画像のようにいくつかブックＡのシートの名前を含むファイルが入っています。別添画像のように、シートの名前は必ず含むものの、ファイル名はバラバラで、「すもも」のようにシートにはないものもあります。そして、「みかん」のようにシートにあるのにファイルがない場合もあります。

このうち、ブックＡに存在するシートの名前を含むファイルのみ開いて閉じるというループのＶＢＡを入力したいのですが、どうすればよいのでしょうか…？！ちなみに、「すもも」のようにブックＡに存在しないシートの名前のファイルは開かないでおきたいです。
「みかん」のようにシートはあるがファイルがない場合は、エラーを出さずそのまま次の処理をすすめたいです。

ちなみに、「新しいフォルダ」の存在する場所は
「C:\Users\PC〇〇〇\Desktop\新しいフォルダ\」です。
ＶＢＡ初心者なので、なるべく簡素なものにしたいと思っています。

ご助力いただけると大変嬉しいです…！よろしくお願いいたしますm(_ _)m

回答No.2

Mathmi

当方の実力不足故シェルスクリプトはよく分からないので、Dirにより検出する方法で作ってみました。

Sub test()
　'アクティブシートの全てのシート名を配列に格納
　Dim SheetNames() As String
　ReDim SheetNames(1 To ActiveWorkbook.Worksheets.Count)
　Dim i As Integer
　For i = 1 To UBound(SheetNames)
　　SheetNames(i) = ActiveWorkbook.Worksheets(i).Name
　Next i

　Const myPath As String = "C:\Users\PC〇〇〇\Desktop"
　Dim myFlg As Boolean
　Dim buf As String
　Dim myBK As Workbook
　buf = Dir(myPath & "\" & "*.xls*")
　Do While buf <> "" '全てのブックを検索
　　myFlg = False
　　'対象のブック名内に、アクティブシートのシート名が含まれているか確認。
　　For i = 1 To UBound(SheetNames)
　　　If InStr(buf, SheetNames(i)) > 0 And InStr(buf, ThisWorkbook.Name) = 0 Then
　　　　myFlg = True
　　　　Exit For
　　　End If
　　Next i
　　'含まれていれば、そのファイルを開いて閉じる。
　　If myFlg = True Then
　　　Set myBK = Workbooks.Open(Filename:=myPath & "\" & buf) '開いたブックを変数myBKに格納
　　　'***各ブックに行う処理を入力***
　　　MsgBox myBK.Worksheets(1).Name '例
　　　myBK.Worksheets("sheet1").Cells(1, 1).Value = 1 '例
　　　'******************************
　　　Call myBK.Close(SaveChanges:=False) '保存せずに終了
　　End If
　　'次のファイル名をbufに格納する。
　　buf = Dir()
　Loop
End Sub

回答No.1

watabe007

>ブックＡに存在するシートの名前を含むファイルのみ開いて閉じる
Sub Test()
　　Dim fso As Object
　　Dim src As Object
　　Dim Fil As Object
　　Dim myPath As String
　　Dim ws As Worksheet
　　Dim myBook As Workbook

　　myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\新しいフォルダ"
　　Set fso = CreateObject("Scripting.FileSystemObject")
　　Set src = fso.GetFolder(myPath)

　　For Each Fil In src.Files
　　　　For Each ws In ThisWorkbook.Worksheets
　　　　　　If Fil.Name Like "*" & ws.Name & "*" Then
　　　　　　　　'シート名に該当するファイルを開く
　　　　　　　　Set myBook = Workbooks.Open(myPath & "\" & Fil.Name)

　　　　　　　　'何らかの処理
　　　　　　　　'処理終了後、開いたブックを上書きして閉じる
　　　　　　　　myBook.Close True
　　　　　　End If
　　　　Next
　　Next
End Sub