フォルダ内のPDFファイルを開く

投稿者 : ST     投稿日時 : 2022/07/25(Mon) 22:19:01     OS : Windows 8.1     EXCEL : Excel 2013

---

Excelファイルにある任意のA列の日付データ（この場合では2020/1/1）をダブルクリックすると隣のB列のデータ及びタブ（シート）名から“C:\○○○\×××\△△△\□□□\シート名“に保存されているPDFファイルを開き、該当ファイルがなければ「ファイルが存在しません」とメッセージを出すようにしたいです。
PDFのファイル名は2000年01月01日（土）_B列のデータのようにA列の日付データを西暦4桁の年と2桁の月と2桁の日に変換されており、括弧は両方とも全角、曜日は西暦を曜日に変換したデータ、_（アンダーバー）、B列のデータのように構成されており、曜日の次の括弧とB列のデータの間は_（アンダーバー）に加え、さらに複数の文字の場合もあります。
イメージ的にはダブルクリックしたA列の日付データかつ隣のB列のデータから上記のフォルダに保存されているデータを部分一致検索で開きたいということになります。
“C:\○○○\×××\△△△\□□□\”をネットワーク（サーバー）上のフォルダ（例えば：\\123.456.789\○○○\×××\△△△\□□□\のようなフォルダ）からでも開けるようにしたいです。

投稿者 : さんこう     投稿日時 : 2022/07/26(Tue) 07:56:01

---

参考になれば。

＞ダブルクリックすると

https://www.google.com/search?q=vba+%E3%83%80%E3%83%96%E3%83%AB%E3%82%AF%E3%83%AA%E3%83%83%E3%82%AF%E3%81%97%E3%81%9F%E3%82%89

＞タブ（シート）名から

https://www.google.com/search?q=vba+%E3%82%B7%E3%83%BC%E3%83%88%E5%90%8D+%E5%8F%96%E5%BE%97

＞PDFファイルを開き

https://www.google.com/search?q=vba+PDF+%E9%96%8B%E3%81%8F

＞メッセージを出す

https://www.google.com/search?q=vba+%E3%83%A1%E3%83%83%E3%82%BB%E3%83%BC%E3%82%B8

＞日付データを西暦4桁の年と2桁の月と2桁の日に変換

https://www.google.com/search?q=vba+%E6%97%A5%E4%BB%98+%E6%96%87%E5%AD%97%E5%88%97

＞部分一致検索で

https://www.google.com/search?q=vba+dir+%E3%83%AF%E3%82%A4%E3%83%AB%E3%83%89%E3%82%AB%E3%83%BC%E3%83%89

投稿者 : ST     投稿日時 : 2022/07/26(Tue) 23:25:30

---

さんこうさん
返信ありがとうございます。
私、VBA初心者ですのでプログラムを記述していただけると助かりますが可能でしょうか？

投稿者 : さんこう     投稿日時 : 2022/07/27(Wed) 08:11:05

---

＞VBA初心者ですのでプログラムを記述していただけると助かりますが可能でしょうか？

完成品が必要でしたら、有料で請け負ってくれるところがあるでしょうから、そちらへどうぞ。


ご自分でチャレンジするのであれば、↓のコードをたたき台としてみてはいかがでしょうか。
（具体的なご質問ならお受けいたします）

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim fp As String
    Dim f As String
    Dim s As String
    
    If Target.Column = 1 Then
        fp = "C:\○○○\×××\△△△\□□□\" & "シート名" & "\"
        
        s = Format(Target, "ggge年m月d日（ddd）_") & "B列のデータ" & ".pdf"
        f = Dir(fp & "\" & s)
        
        If f <> "" Then
            MsgBox fp & "\" & f & "を開いてください。"
        Else
            MsgBox s & "はありません"
        End If
        Cancel = True
    End If
End Sub

投稿者 : ST     投稿日時 : 2022/07/27(Wed) 22:43:18

---

さんこうさん
丁寧なプログラムの返信ありがとうございます。
素人考えですが少し変更し以下のプログラムで試してみました。
内容的には"C:¥○○○¥×××¥△△△¥□□□¥" & ActiveSheet.Name"フォルダ内に該当するファイルがあればファイルが開き、なければ"ファイルが存在しません"というメッセージをウィンドウで表示するプログラムです。
A列のセルには2000/1/1と入力されたデータがセルの書式設定で1/1（土）と表示されています。
開きたいPDFファイルは上記のフォルダの直下に”2000年01月01日（土）_B列のデータ”や”2000年01月01日（土）_A店舗_B列のデータ”というように年月日とB列の間の文字の種類・文字数は様々な状態で保存されています。
フォルダ内にPDFファイルは存在するのですが開くことができません。
どこがどう間違っているのでしょうか？
イメージ的には”A列のデータ　かつ　B列のデータを含み　かつ　A列のデータとB列のデータの間の文字の種類・文字数はランダム”というようなことを意味するプログラムが作成したいと考えています。
どこが間違っているのでしょうか？
添削と同時にプログラムを教えていただけると幸いです。
よろしくお願い致します。
----------------------------------------------

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Intersect(Target, Range("A8:A1048576")) Is Nothing Then

    Dim y As String
    Dim m As String
    Dim d As String
    Dim Inputname As String
    Dim fp As String
    Dim f As String
    Dim s As String
    
    y = Format(ActiveCell.Value, "yyyy")
    m = Format(ActiveCell.Value, "mm")
    d = Format(ActiveCell.Value, "dd")
    
    Inputname = y & "年" & m & "月" & d & "日"     
    

    fp = "C:¥○○○¥×××¥△△△¥□□□¥" & ActiveSheet.Name & "\"
        
    s = Inputname & "（" & WeekdayName(Weekday(ActiveCell.Value), True) & "）" & "_" & ActiveCell.Offset(0, 1).Value & ".pdf"

    f = Dir(fp & "\" & s)
        
    If f <> "" Then

      CreateObject("Shell.Application").ShellExecute f

      Else
       MsgBox "ファイルが存在しません"

      End If

    Cancel = True

   End If

End Sub

投稿者 : さんこう     投稿日時 : 2022/07/27(Wed) 23:28:48

---

＞A列のデータとB列のデータの間の文字の種類・文字数はランダム”というようなこと

Dir関数に「ワイルドカード」を組み合わせるといいでしょう。

https://www.google.com/search?q=vba+dir+%E3%83%AF%E3%82%A4%E3%83%AB%E3%83%89%E3%82%AB%E3%83%BC%E3%83%89


＃余計なお世話ですが、想定したファイル名になるまでは下記↓のようにして、ファイル名を確認できるようにするといいでしょう。

If f <> "" Then
MsgBox fp & "¥" & f & "を開いてください。"
' CreateObject("Shell.Application").ShellExecute f
Else
MsgBox s & "はありません"
'MsgBox "ファイルが存在しません"
End If

投稿者 : さんこう     投稿日時 : 2022/07/29(Fri) 07:51:06

---

＞ f = Dir(fp & "¥" & s)

「"\"」不要でしたね。失礼しました。

↓に修正して下さい。

f = Dir(fp & s)

投稿者 : ST     投稿日時 : 2022/07/31(Sun) 21:26:04

---

■[返信 6] さんこうさん（2022-07-29 07:51:06）の記事
＞ ＞ f = Dir(fp & "¥" & s)
＞
＞ 「"\"」不要でしたね。失礼しました。
＞
＞ ↓に修正して下さい。
＞
＞ f = Dir(fp & s)
＞

さんこうさん
ありがとうございます。
早速、試してみました。
上記の修正後のプログラムでも”「開きたいPDFファイル名」が見つかりません。名前を正しく入力したかどうかを確認してから、やり直してください。”とメッセージが表示されます。
「開きたいPDFファイル名」には開きたいファイル名は表示されいるためフォルダ内のファイルは見に行っているようですがファイル自体を開くことができませんでした。

投稿者 : さんこう     投稿日時 : 2022/07/31(Sun) 21:44:13

---

＞CreateObject("Shell.Application").ShellExecute f

↑これを変えていないなら、ファイルが存在しないフォルダを見に行っている可能性があります。

＜参考＞
https://www.google.com/search?q=vba+%E3%83%91%E3%82%B9%E7%9C%81%E7%95%A5

投稿者 : ST     投稿日時 : 2022/08/11(Thu) 21:59:36

---

■[返信 8] さんこうさん（2022-07-31 21:44:13）の記事
＞ ＞CreateObject("Shell.Application").ShellExecute f
＞
＞ ↑これを変えていないなら、ファイルが存在しないフォルダを見に行っている可能性があります。
＞
＞ ＜参考＞
＞ https://www.google.com/search?q=vba+%E3%83%91%E3%82%B9%E7%9C%81%E7%95%A5
＞

さんこうさん
お世話になっております。
以降、多忙につきしばらくできませんでしたが最近再開しました。
以下のように他のホームページを参考に変えてみました。
以下ですとファイルを開くことができましたが、ファイルが存在しない場合は挙動がありません。
ファイルがフォルダ内に存在しない場合に”ファイルが存在しません”とのメッセージボックスを出したいのですがどこにどのようなプログラムを追加すればいいのでしょうか？
-------------------------------------------

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Intersect(Target, Range("A8:A1048576")) Is Nothing Then

  Dim y As String
  Dim m As String
  Dim d As String
  Dim Inputname As String
  Dim fp As String
  Dim f As Object

  y = Format(ActiveCell.Value, "yyyy")
  m = Format(ActiveCell.Value, "mm")
  d = Format(ActiveCell.Value, "dd")

  Inputname = y & "年" & m & "月" & d & "日"

  fp = "C:¥○○○¥×××¥△△△¥□□□\" & ActiveSheet.Name

  With CreateObject("Scripting.FileSystemObject")

  For Each f In .GetFolder(fp).Files
 
  If InStr(f, ActiveCell.Offset(0, 1).Value) > 0 And InStr(f, Inputname) > 0 Then

  CreateObject("Shell.Application").ShellExecute f

  End If

  Next f
  
 End With

 Cancel = True

 End If
    
End Sub

投稿者 : さんこう     投稿日時 : 2022/08/12(Fri) 09:59:26

---

元のDirを使った方法がシンプルなように思いますが、好みの問題なので。

さて、
＞ファイルがフォルダ内に存在しない場合に”ファイルが存在しません”とのメッセージボックスを出したい
ですが、

↓のループを回りきったら（全てのファイルがIF文の条件に合わなかったら）「ファイルが存在しない」ことになりますので、
---------------------------
For Each f In .GetFolder(fp).Files

If InStr(f, ActiveCell.Offset(0, 1).Value) > 0 And InStr(f, Inputname) > 0 Then

CreateObject("Shell.Application").ShellExecute f

End If

Next f
---------------------------
・ループの前にフラグを初期化
・IF文の条件に合ったらフラグをセット
・ループ後にフラグがセットされていなかったら、メッセージを出す
といった感じになります。

＜参考＞
https://www.google.com/search?q=VBA+%E3%83%95%E3%83%A9%E3%82%B0

投稿者 : ST     投稿日時 : 2022/08/12(Fri) 19:40:31

---

■[返信 10] さんこうさん（2022-08-12 09:59:26）の記事
＞ 元のDirを使った方法がシンプルなように思いますが、好みの問題なので。
＞
＞ さて、
＞ ＞ファイルがフォルダ内に存在しない場合に”ファイルが存在しません”とのメッセージボックスを出したい
＞ ですが、
＞
＞ ↓のループを回りきったら（全てのファイルがIF文の条件に合わなかったら）「ファイルが存在しない」ことになりますので、
＞ ---------------------------
＞ For Each f In .GetFolder(fp).Files
＞
＞ If InStr(f, ActiveCell.Offset(0, 1).Value) > 0 And InStr(f, Inputname) > 0 Then
＞
＞ CreateObject("Shell.Application").ShellExecute f
＞
＞ End If
＞
＞ Next f
＞ ---------------------------
＞ ・ループの前にフラグを初期化
＞ ・IF文の条件に合ったらフラグをセット
＞ ・ループ後にフラグがセットされていなかったら、メッセージを出す
＞ といった感じになります。
＞
＞ ＜参考＞
＞ https://www.google.com/search?q=VBA+%E3%83%95%E3%83%A9%E3%82%B0
＞

さんこうさん
連絡ありがとうございます。
指摘の内容で他のホームページも参考にしながらですが何とかできました。
動作も問題ありませんでした。
ありがとうございました。
長きにわたりご教授いただきありがとうございました。
御礼申し上げます。
また何かありましたら連絡させていただきますのでその時はどうぞよろしくお願い致します。
以下参考までに完成したプログラムを掲載させていただきます。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Intersect(Target, Range("A8:A1048576")) Is Nothing Then

  Dim y As String
  Dim m As String
  Dim d As String
  Dim inputname As String
  Dim filepath As String
  Dim filename As Object

  Flag = 0
  
  y = Format(ActiveCell.Value, "yyyy")
  m = Format(ActiveCell.Value, "mm")
  d = Format(ActiveCell.Value, "dd")

  inputname = y & "年" & m & "月" & d & "日"
  
  filepath = "C:¥○○○¥×××¥△△△¥□□□¥" & ActiveSheet.Name

  With CreateObject("Scripting.FileSystemObject")
  
    For Each filename In .GetFolder(filepath).Files
    
      If InStr(filename, ActiveCell.Offset(0, 1).Value) > 0 And InStr(filename, inputname) > 0 Then Flag = 1
  
      If Flag = 1 Then
      
        CreateObject("Shell.Application").ShellExecute filename
  
        Exit For
  
      End If

    Next filename
  
    If Flag = 0 Then
  
      MsgBox "該当のファイルは見つかりません。"
  
    End If
  
  End With

 Cancel = True

End If
    
End Sub

投稿者 : さんこう     投稿日時 : 2022/08/15(Mon) 08:26:04

---

質問者さんはもう見ていないと思いますが、あとで見る人への参考として。

＞投稿者 : ST 投稿日時 : 2022/07/27(Wed) 22:43:18
↑のコードを修正すると、こんな感じになります。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Columns("A")) Is Nothing Then
        Dim Inputname As String
        Dim fp As String
        Dim f As String
        Dim s As String
        
        Inputname = Format(ActiveCell.Value, "yyyy年mm月dd日（aaa）")
        fp = "C:\○○○\×××\△△△\□□□\" & ActiveSheet.Name & "\"
        s = Inputname & "*" & "_" & ActiveCell.Offset(0, 1).Text & ".pdf"
    
        'MsgBox fp & s
    
        f = Dir(fp & s)
        If f <> "" Then
            CreateObject("Shell.Application").ShellExecute fp & f
        Else
            MsgBox "ファイルが存在しません"
        End If
        Cancel = True
   End If
End Sub