1つだけ過去を変えられるとしたら?

以前に質問をさせていただき、こちらでベストアンサーを決定した後に急きょ変更があったところがあり、わからなくなってしまいこちらに戻ってきた次第です。

http://oshiete.goo.ne.jp/qa/8743521.html

にて質問をさせていただきました内容について、以下のVBAで解決できております。
しかし、抽出したファイル名にハイパーリンクが欲しいという要望を受けてしまいました。
ハイパーリンクのVBAについていろいろ調べましたが、この記述方法に追加して実行する方法が全く分かりませんでした。

お分かりになる方がいましたら、この内容にハイパーリンクをつける方法をお教えいただけますでしょうか。よろしくお願いいたします。

Sub Macro1()
Dim i As Long
Dim myPath As String, Flnm As String
ReDim Flnmfp(0) As String
Dim WS1 As worksheet
Set WS1=ThisWorkbook.sheets("sheet1")

myPath="望みのフォルダパスを入力"
Call fpFileName(myPath, Flnmfp ) 'フォルダ内のファイル名取得
If Ubound(Flnmfp)=0 Then 'フォルダにファイルが無ければ終了
Exit Sub
End if

For i =1 to Ubound(Flnmfp)
Workbooks.open filename := Flnmfp(i)
Flnm=Dir(Flnmfp(i))
With Workbooks(Flnm).sheets("sheet1")
WS1.Cells(2, i).value=.Range("G5").value
WS1.Cells(3, i).value=.Range("G6").value
WS1.Cells(4, i).value=.Range("K7").value
WS1.Cells(5, i).value=CStr(.Range("G9").value) & CStr(.Range("N9").value) & CStr(.Range("P9").value)
'同じ要領で望みのセルを記入する
WS1.Cells(8, i).value=Flnm
End with
Workbooks(Flnm).close Savechanges:=False

Next i
End Sub

Sub fpFileName(ByVal myPath As String, ByRef Flnmfp() As String)
'サブフォルダも含め全部のxlsファイル名をフルパスで取得する
  Dim cnt As Long, buf As String, f As Object

  buf = Dir(myPath & "\*.xls")
  Do While buf <> ""
    cnt = Ubound(Flnmfp) + 1
ReDim Preserve Flnmfp(cnt)
    Flnmfp(cnt)= myPath & "\" & buf
    buf = Dir()
  Loop
  With CreateObject("Scripting.FileSystemObject")
    For Each f In .GetFolder(myPath).SubFolders
      Call fpFileName(f.Path, Flnmfp)
    Next f
  End With
End Sub

A 回答 (2件)

For i=1 to Ubound(Flnmfp)の上に


WS1.HyperLinks.Delete
を追加。処理前に全ハイパーリンクを解除する。

Next iの上に
WS1.Hyperlinks.Add Anchor:=Cells(8, i), Address:=Flnmfp(i)
    • good
    • 0

社内で出来る人が居ないなら、この機会に勉強してはどうですか?私もプログラマではなく、仕事上の必要から勉強した片手間VBAです。

1年位ですよ。

ただし、手広くやり過ぎるとマクロ係みたいになって本業から外されるリスクがあるのでご注意を。
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!