エクセルにファイルを添付したい

質問

エクセルで表を作成しています。そこに他のＰＤＦ文書を貼り付けたいと思います。どのようにしたら良いでしょうか？

問題点
１　ＰＤＦファイルは画像のように貼るのではなくハイパーリンクでつけたい
２　このＰＤＦファイル自体がときどき更新されるため、ＰＤＦファイル名を～20061201.pdfのように、いつＰＤＦファイルが更新されたかわかるようにしたい
３　エクセル自体はあまり更新しない予定なので、ハイパーリンクでつけたＰＤＦファイルが常に最新のものにしたい

以上のような状態です。現在はふつうにＰＤＦファイルをハイパーリンクでつけていますが、このままではＰＤＦファイルを更新した時、すべて同じように更新しなければならないので困ってます。ファイルではなくフォルダに日付を入れることも検討したのですが、フォルダ名を変更するとハイパーリンクでは検索されなくなってしまいますよね？
お力添えお願いします。

回答No.1

noname#22650 · ベストアンサー

マクロ(VBA)を使うしかないと思います。

----以下ソース----
Private Function 日付チェック(path) As Long
　Dim fname As String
　Dim d As Long
　Dim last As Long

　日付チェック = -1
　ChDir ActiveWorkbook.path
　fname = Dir(path)
　Do While (fname <> "")
　　If fname Like "*########.pdf" Then
　　　d = Val(Mid(fname, Len(fname) - 11, 8))
　　　If d > last Then last = d
　　End If
　　fname = Dir()
　Loop
　日付チェック = last
End Function

Sub リンク更新()
　Dim l As Hyperlink
　Dim d As Long

　For Each l In ActiveSheet.Hyperlinks
　　If l.Address Like "*########.pdf" Then
　　　d = 日付チェック(Left(l.Address, Len(l.Address) - 12) & "*.pdf")
　　　If d <> -1 Then
　　　　l.Address = Left(l.Address, Len(l.Address) - 12) & Trim(Str(d)) & ".pdf"
　　　　l.Range = Left(l.Address, Len(l.Address) - 12) & Trim(Str(d)) & ".pdf"
　　　End If
　　End If
　Next
End Sub
----以上ソース----

先に「～20061201.pdf」へのリンクを作って下さい。
「リンク更新」を実行するとアクティブシートのリンクを更新します。
「～20061201.pdf」と同じフォルダにある新しい日付のファイルを探し、リンクを書き換えます。

念のためバックアップを取ってから、お試しください。

お礼

丁寧な回答ありがとうございます。マクロで対応するしかないのですね。未知の領域ですがためしてみたいと思います。ありがとうございました。

回答No.2

Wendy02

こんばんは。

私も考えてみました。状況がはっきりしていないので、ある程度、こちらできめてしまいました。ファイル名自体は、何にしようが、そのブックの下位フォルダーのどこに入れようが別に問題はありません。そのブックの上位フォルダは、現在は探しません。

もっとも新しいpdfファイルを探すマクロです。

ファイルの日付は、ハイパーリンクのポップアップに入れました。ファイル名とは別です。

ただし、あまり、上のフォルダでファイルが多いと時間が掛かります。
ハイパーリンクは、一つしかないことを条件にして、それが書き換わります。

なお、Excel 2000 以下では、このマクロは、やってみないと分からないです。また、IE は、5.0 以上を条件としています。

'--------------------------------------------------

Sub NewHyperLinkChanging()
'ハイパーリンクを最新のファイルに書き換えるマクロ
Dim r As Range
Dim d As Date
Dim Fname As String
Dim f As Variant
Dim Disp As String
'ハイパーリンクの一つに対して、最新のファイルに書き換えられる
'日付は、ヒントに出てくる
If ActiveSheet.Hyperlinks.Count = 0 Then
　　MsgBox "Hyperlink がありませんので、終了します。": Exit Sub
Else
　 Set r = ActiveSheet.Hyperlinks(1).Range
End If

With Application.FileSearch
　 .NewSearch
　　.LookIn = ThisWorkbook.Path　'親パス
　　.SearchSubFolders = True
　　.Filename = "*.pdf"　　'なるべく頭出しを限定したほうがよい
　　'特徴のある語でもよい。例06*.pdf
　　.MatchTextExactly = False
　　.FileType = msoFileTypeAllFiles
　If .Execute() > 0 Then

　　　 For Each f In .FoundFiles
　　　 If FileDateTime(f) > d Then
　　　　 d = FileDateTime(f)
　　　　 Fname = f
　　　 End If
　　　 Next f
　　Else
　　　　MsgBox "検索条件を満たすファイルはフォルダにはありません。"
　　　　Set r = Nothing
　　　　Exit Sub
　　End If
End With

　　Disp = Mid$(Fname, InStrRev(Fname, "\") + 1)
　　With r.Hyperlinks(1)
　　　　 .Address = Fname
　　　　 .ScreenTip = Format(d, "yymmdd")
　　　　 .TextToDisplay = Disp
　　End With
　　Set r = Nothing
End Sub

'--------------------------------------------------

お礼

丁寧な回答ありがとうございます。マクロで対応するしかないのですね。未知の領域ですがためしてみたいと思います。ありがとうございました。