VBAでハイパーリンクをつける

質問

仕事で画像のファイル名をExcelに書き出し、書き出しものにハイパーリンクで見がうまくいきません。下記のものです。どこが悪いのでしょうか？
Option Explicit
Dim ドライブ As String
Dim フォルダ As String
Dim 拡張子 As String
Dim 記入シート As String
Dim パス As String
Dim ファイル名 As String
Dim 貼付行 As Integer
Sub フォルダ中のファイル名をシートに書く()
ドライブ = "C"
フォルダ = "分析"
拡張子 = "*." & "JPG"
記入シート = "ファイル一覧"
End Sub
Private Sub 指定フォルダ中の指定拡張子のファイル名をシートに書く()
Sheets(記入シート).Activate
Cells.Clear
Range("A1").Select
パス = ドライブ & ":\" & フォルダ & "\"
ファイル名 = Dir(パス & 拡張子)
貼付行 = 0
Do While ファイル名 <> ""
貼付行 = 貼付行 + 1
Cells(貼付行, 1).Value = ファイル名
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=ファイル名, TextToDisplay:=ファイル名
ファイル名 = Dir()
Loop
End Sub
実行すると初めの一行だけリンクができ後は一行もできません。よろしくお願い致します。

回答No.1

BLUEPIXY · ベストアンサー

＞Anchor:=Selection
になってるからじゃないですか
Anchor:=Cells(貼付行, 1)
にしてみたらどうでしょう

お礼

できました。ありがとうございます。
ディスプレイの拡張子をはぶくものは
別で、質問したいと思います。
ありがとうございました。

補足

できました！ありがとうございます。
TextToDisplayで拡張子が○○○.jpgと着きますが
この拡張子無しで表示したいのですが
この部分を消しても意味はないのですね。
(1)Dim 拡張子 As String
(2)拡張子 = "*." & "JPG"
(3)ファイル名 = Dir(パス & 拡張子)⇒この「&拡張子」の部分
たぶんこのDirに意味があるのでしょうか？

回答No.2

dennou2000

ANo.1の方の方法でもいいですが、そうすると下記の※の部分の意味がなくなります。
且つそこが問題点なのですが・・・

Private Sub 指定フォルダ中の指定拡張子のファイル名をシートに書く()
　　Sheets(記入シート).Activate
　　Cells.Clear
　　Range("A1").Select '※
　　パス = ドライブ & ":\" & フォルダ & "\"
　　ファイル名 = Dir(パス & 拡張子)
　　貼付行 = 0
　　Do While ファイル名 <> ""
　　　　貼付行 = 貼付行 + 1
　　　　Cells(貼付行, 1).Value = ファイル名
　　　　ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=ファイル名, TextToDisplay:=ファイル名
　　　　ファイル名 = Dir()
　　Loop
End Sub

※の箇所で選択しているのはＡ1のセルのみです。
一方で、ActiveSheet.Hyperlinks.Addメソッドで、Anchor:=SelectionとしてSelectionプロパティ
を指定していますから、選択されている部分しか追加されません。
従って、Range("A1").Selectで選択されているセルにしか追加されません。

【対処方法】

　　Do While ファイル名 <> ""
　　　　貼付行 = 貼付行 + 1
　　　　Range("A" & CStr(貼付行).Select　　　’変更点
　　　　Selection.Value = ファイル名　　　　　’変更点
　　　　ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=ファイル名, TextToDisplay:=ファイル名
　　　　ファイル名 = Dir()
　　Loop

という形にして、逐次セル単位でセレクトをかける形にすればいいと思います。
動作確認：Windows2000 Professional SP2、Office2000