[VBA]VBAで指定したキーワードでExcelブックを開く

こんにちは。
VBAで指定したキーワードで同じフォルダ内のExcelブックを開きたいのですが、
たとえば、ブック名に[みかん]というキーワードが入っている場合に、開く。
また、エクセルの拡張子はxlsxとxlsmの可能性があるので、下記コードで実現できると思いますが、
Workbooks.Open FileName:=ThisWorkbook.Path & "\" & Dir(ThisWorkbook.Path & "\" & "愛媛県みかん.xls*")

しかし、どうやってブック名に[みかん]というキーワードが入っている場合に、開けるようにしますか？
ご教示お願い致します。

質問者からの補足コメント

• ご回答ありがとうございます。
  コードでやってみたところ、実現できました。
  参考になりました。
  感謝致します。
  ちなみに、シート１のA１セルへの入力なしで、VBAコードでキーワードを指定することができますでしょうか？

  No.2の回答に寄せられた補足コメントです。 補足日時：2020/02/14 13:34

• ご回答ありがとうございます。
  シンプルに考えると、
  たとえば、同じフォルダ内にみかん１２３というブックが存在されていて、
  ブック名に「みかん」というキーワードが入っている場合に、それを開くっていうことです。
  複数の可能性がございません。
  ご教示お願い致します。

  No.4の回答に寄せられた補足コメントです。 補足日時：2020/02/14 14:13

• これは一個上のフォルダにブック名にみかんががある場合にブックを開くコードですが、
  どうやって同じフォルダ内のブックを開けるように改造したらよろしいでしょうか？
  Dim Filepath As String, FileName As String
  Dim TargetWorkbook As Workbook
  Filepath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1) & "\"
  If Dir(Filepath & "*みかん.xlsx") = "" Then
  MsgBox "ファイルは存在していません"
  Exit Sub
  End If
  FileName = Dir(Filepath & "*みかん.xlsx")
  Workbooks.Open FileName:=Filepath & FileName

  No.5の回答に寄せられた補足コメントです。 補足日時：2020/02/14 14:40

No.6 ベストアンサー 回答者： Qchan1962 回答日時： 2020/02/14 14:39

＞複数の可能性がございません。

複数なければ、　＃2の回答でもよろしいかと思います。

＃３の返信
示されているソースコードは、マクロ実行ブックの親フォルダ内を探しているようですね。
あるかどうかを確認しているファイル名も違うので、、ちょっと分かりませんし本スレッドから
ずれますので、別スレッド（再質問）などをしてくださいね。

＃４の追記
＞ちなみに、シート１のA１セルへの入力なしで、VBAコードでキーワードを指定することができますでしょうか？
直接で良いなら、（＃２の回答例）Tgt_BkName = "みかん"
でよろしいと思います。

この回答へのお礼

なるほどですね。
誠にありがとうございました。
実現できました。
助かりました。

お礼日時：2020/02/14 14:45

No.5 回答者： Qchan1962 回答日時： 2020/02/14 14:22

＞ちなみに、シート１のA１セルへの入力なしで、VBAコードでキーワードを指定することができますでしょうか？

？どこからキーワード（みかん）を指定するのですか？？

No.4 回答者： Qchan1962 回答日時： 2020/02/14 13:57

＞VBAコードでキーワードを指定することができますでしょうか？

意味が広すぎますね。
InputBoxからとか、算出結果からとか、、TextBoxからとか、、、
何からにしますか？

No.3 回答者： Qchan1962 回答日時： 2020/02/14 13:54

検証してみました。

ほんと抜け策です。すみません。
追加と変更が必要ですね。
変数を追加して、訂正するか、1行追加して是正するか、、、
後者が簡単ですが、やっつけ感があるので、しっかり変数を追加して対処します。

Dim keyword As String　

訂正箇所（2行）

Tgt_BkName = Sheets(1).Range("A1")　を　keyword = Sheets(1).Range("A1")

If InStr(file.Name, Tgt_BkName) > 0 Then　を　If InStr(file.Name, keyword) > 0 Then

以上です。

ミスから出た機会ですが、＃１、＃２、＃３の挙動の違いを考えてみてくださいね。　
度々すみませんです。

この回答へのお礼

お手数をおかけしまして申し訳ございません。
参考になりました。
ちなみに、下記コードは一個上のフォルダに保存しているブックに「みかん」というキーワードが入っていたら、それを開くものです。
どうやって改造して、本題に使用できるようになりますでしょうか？

Dim Filepath As String, FileName As String '一個↑のフォルダにブック名を「品番」をキーワードに指定し、ブックを開く
Dim TargetWorkbook As Workbook
Filepath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1) & "\"
If Dir(Filepath & "*みかん.xlsx") = "" Then
MsgBox "ファイルは存在していません"
Exit Sub
End If
FileName = Dir(Filepath & "*品番.xlsx")
Workbooks.Open FileName:=Filepath & FileName

お礼日時：2020/02/14 14:17

No.2 回答者： Qchan1962 回答日時： 2020/02/14 13:18

＃１投稿した後気づきました、少し安直でした

文字が入って要る場合なら、これではだめですね。
また、おなじ名前のワードファイルが入っていても、正しく動作しませんね。
早速直したので、こちらを、、、各ソースコードについては、自己学習でお願いいたします。
先ずは、訂正します。

Sub OpenFiles_Folder()
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tgt_BkName As String, ExtensionName As String
Dim file As Variant
Tgt_BkName = Sheets(1).Range("A1")　　　　'シートインデックス1（一番左のシート）のA1セルの値
On Error Resume Next　　　 '未検証の為（検証時外してください。問題ない場合は再設定）

For Each file In fso.GetFolder(ThisWorkbook.path).files　　 'フォルダ内の全ファイルについて処理
If InStr(file.Name, Tgt_BkName) > 0 Then　　　　　 'ブック名にキーワードがあるか----
　　　　　　Tgt_BkName = fso.GetBaseName(file.Name)
　　　　　　ExtensionName = fso.GetExtensionName(file.Name)
　　　　　　If ExtensionName Like "xls*" Then
　　　　　　　　Workbooks.Open _
　　　　　　　　　　　　Filename:=ThisWorkbook.path & "\" & _
　　　　　　　　　　　　　　　　　Dir(ThisWorkbook.path & "\" & Tgt_BkName & ".xls*")　　'ファイルを開く
　　　　　　End If
　　　　End If
　　Next file
End Sub

この回答へのお礼

ご回答ありがとうございます。
コードでやってみたところ、実現できました。
参考になりました。
感謝致します。
ちなみに、シート１のA１セルへの入力なしで、VBAコードでキーワードを指定することができますでしょうか？

お礼日時：2020/02/14 13:38

No.1 回答者： Qchan1962 回答日時： 2020/02/14 12:53

こんにちは、

キーワードを変数に入れてみては？
変数名は任意名、　型はString
Dim Tgt_BkName As String
Tgt_BkName = Sheets(1).Range("A1") 'シートインデックス1（一番左のシート）のA1セルの値
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & Dir(ThisWorkbook.Path & "\" & Tgt_BkName & ".xls*")
となりますが、、、

開くブック名にみかんがある時に開くのであれば、、

Sub OpenFiles_Folder()
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tgt_BkName As String
Dim file As Variant
Tgt_BkName = Sheets(1).Range("A1")　　　　'シートインデックス1（一番左のシート）のA1セルの値
On Error Resume Next　　　'未検証の為（検証時外してください。問題ない場合は再設定）
　　For Each file In fso.GetFolder(ThisWorkbook.path).files 'フォルダ内の全ファイルについて処理
　　　　If InStr(file.Name, Tgt_BkName) > 0 Then　 'ブック名にキーワードがあるか----
　　　　　　Workbooks.Open _
　　　　　　　　　　Filename:=ThisWorkbook.path & "\" & _
　　　　　　　　　　　　　　　Dir(ThisWorkbook.path & "\" & Tgt_BkName & ".xls*") 'ファイルを開く
　　　　End If
　　Next file
End Sub

既に開いている場合などのエラー処理をしてください。
一応、 On Error Resume Next　のみ入れました。
Sheets(1).Range("A1")　＝　みかん

こんな感じでしょうか？