エクセルVBAで教えてください。

質問

サイトで既出のコードを若干変えて下のようにして使っています。
下のコードでダイアログを呼び出し、フォルダを指定して、ハイパーリンクでそのフォルダを開くようになっているのですが、ファイルそのものを指定して、ハイパーリンクでファイルを開くようにするにはどうすればいいでしょうか。下のコードの一部を変えれば可能であれば、下のコードを踏襲して教えていただければ有難いです。
よろしくお願いします。

Sub hyperlink()
Dim Fol As Object
Dim fp As String

Set Fol = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フルパスを取得します。ハイパーリンクにしたいフォルダを指定してください。", 0)
If Not Fol Is Nothing Then
Range("IV1").Value = Fol.Items.Item.Path
End If
Application.ScreenUpdating = False
Range("IV1").Copy
Range("A65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
fp = Range("A65536").End(xlUp).Value
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fp, TextToDisplay:=fp

Application.CutCopyMode = False
Range("IV1").ClearContents

Application.ScreenUpdating = True
MsgBox "ハイパーリンクを設定しました。"

End Sub

回答No.2

Masa2072 · ベストアンサー

コモンダイアログにはComdlg32.ocxが必要でOfficeには入っていませんでした。
というわけで再度修正
Sub hyperlink3()
Dim objXLS As New Excel.Application
Dim File As Variant
Dim fp As String

'今度はEXCELのアプリケーションオブジェクトなので大丈夫だと思います
File = objXLS.GetOpenFilename("全てのファイル,*.*", , "ファイルの指定")

If Not (File = False) Then
Range("IV1").Value = File
'End If <== ココにEnd Ifだとキャンセル時に処理がおかしいのでコメントアウト
Application.ScreenUpdating = False
Range("IV1").Copy
Range("A65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
fp = Range("A65536").End(xlUp).Value
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fp, TextToDisplay:=fp

Application.CutCopyMode = False
Range("IV1").ClearContents

Application.ScreenUpdating = True
MsgBox "ハイパーリンクを設定しました。"
'キャンセル時の処理を追加
Else
MsgBox "処理を中止しました。"
End If
End Sub

という感じでどうでしょうか、今度は大丈夫だと思うのですが・・・大変失礼しました。

お礼

ありがとうございました！ばっちりでした。
すばらしいコードありがとうございました。とても自分では考えられないものでした。

回答No.3

Masa2072

重ね重ね申し訳ありません。
ExcelのVBAなんだから
Dim objXLS As New Excel.Application
は不要で

File = Application.GetOpenFileName(・・・・・・・
でOKです。

回答No.1

Masa2072

File用に少し変更

Sub hyperlink2()
Dim File As Object
Dim fp As String

'Shell.Application.BrowseForFolderの変わりにコモンダイアログを使用しました
Set File = CreateObject("MSComDlg.CommonDialog")
File.ShowOpen

If Not IsNull(File.Filename) Then
Range("IV1").Value = File.Filename
End If
Application.ScreenUpdating = False
Range("IV1").Copy
Range("A65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
fp = Range("A65536").End(xlUp).Value
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fp, TextToDisplay:=fp

Application.CutCopyMode = False
Range("IV1").ClearContents

Application.ScreenUpdating = True
MsgBox "ハイパーリンクを設定しました。"

End Sub

お礼

Masa2072さんこんばんは。ありがとうございました。実行したところ
「実行時エラー　ActiveXコンポーネントはオブジェクトを作成できません」となります・・・。特別な設定が必要でしょうか？