Excelでのマクロ化

質問

Ｅｘｃｅｌ（2000）の表のＢ列に2000.doc～順にファイル名(全て数字＋拡張子）が入っています。それにリンクを貼っていきたいのですが、マクロで自動化するにはどのようにすれば良いのでしょうか？また、拡張子がｄｏｃで存在しないものには、代わりにｔｘｔのものを貼りたいのですが。どちらも同じフォルダにありますし、ｄｏｃもｔｘｔもあるものもありますが、ｄｏｃもしくは、ｔｘｔは必ず存在します。
　ちなみに、今までは、手で1つづつハイパーリンクで貼っていたのですが、先日より1日に5～10ファイルづつ増えてくるようになったので困っています。
　また、このようなマクロの参考書で、これが良いよというものを紹介していただけるとありがたいのですが。もちろん、ＨＰのＵＲＬでも構いません。
よろしくお願いします。

回答No.1

yoshisuke · ベストアンサー

私の環境はExcel97なので動くかどうかわかりませんが
こんなマクロでできました。
ご参考までに。。。

Option Explicit

Sub makeLink()
'//変数宣言

　　Dim objFileSystem As Object 'ファイルシステムオブジェクト
　　Dim objDir As Object 'ディレクトリ
　　Dim objFilecol As Object 'ファイルコレクション
　　Dim objFile As Object 'ファイルオブジェクト

　　Const strTargetDir As String = "D:\Data" '対象フォルダ名

　　Dim intLine As Integer 'リンク作成行
　　Dim strFileName As String 'ファイル名

'//シートクリア
　　Cells.ClearContents

'//フォルダにあるファイル情報を取得
　　Set objFileSystem = CreateObject("Scripting.FileSystemObject")
　　Set objDir = objFileSystem.GetFolder(strTargetDir)
　　Set objFilecol = objDir.Files

'//リンクを作成
　　intLine = 1
　　For Each objFile In objFilecol
　　　　strFileName = objFile.Name
　　　　If Right(strFileName, 3) = "doc" Or _
　　　　　　　　Right(strFileName, 3) = "txt" Then
　　　　　　ActiveSheet.Hyperlinks.Add anchor:=Cells(intLine, 1), _
　　　　　　　Address:=strTargetDir & "\" & strFileName

　　　　　　intLine = intLine + 1
　　　　End If
　　Next

End Sub

補足

早速有難うございました。
　すみませんが、質問内容に不備があり、もう一度質問させていただきます。その際には、またよろしくお願いします。

回答No.2

noname#102878

・Excelのセルに書かれているWordファイル名と同じWordファイル、または同名のTextファイルがExcelファイルが存在するフォルダ内にある。
・Wordファイルが存在しなくても、同名のTextファイルが存在するかもしれない。
・両方ともない場合も考えられなくはない。
・Wordファイルが存在すればWordファイルにリンクを張る。
・Wordファイルが存在しなければTextファイルを探し、存在すればTextファイルにリンクを張る。
・どちらも存在しなければリンクを張らない。

という条件で作成してみました。
毎回一度リンクを解除しますので、WordファイルとTextファイル両方が存在しなければリンク解除のままです。
以下を標準モジュールに貼り付けて使ってみてください。

Sub SetHyperLink()
　Dim fso As Object

　Dim lngLast As Long ' 最終行番号
　Dim i As Long
　Dim strCellFName As String ' セルに書きこまれているWordファイル名

　Set fso = CreateObject("Scripting.FileSystemObject")

　lngLast = Range("B65536").End(xlUp).Row ' 最終行番号を取得

　For i = 1 To lngLast
　　Cells(i, 2).Hyperlinks.Delete ' 既存のハイパーリンクを削除

　　strCellFName = Cells(i, 2).Value ' Cellに書かれたWordファイル名を取得

　　If fso.FileExists(ThisWorkbook.Path & "\" & strCellFName) = True Then
　　　' Cellに書かれているWordファイルが存在したので、Wordファイルにリンクを張る
　　　Cells(i, 2).Hyperlinks.Add anchor:=Cells(i, 2), _
　　　　　　　　　　　　　　　　　　Address:=strCellFName
　　ElseIf fso.FileExists(ThisWorkbook.Path & "\" & fso.GetBaseName(strCellFName) & ".txt") = True Then
　　　' Cellに書かれているWordファイルは存在しなかったが、
　　　' 同じ名前のTextファイルが存在したので、Textファイルにリンクを張る
　　　Cells(i, 2).Hyperlinks.Add anchor:=Cells(i, 2), _
　　　　　　　　　　　　　　　　　Address:=fso.GetBaseName(strCellFName) & ".txt"
　　End If
　Next i

　Set fso = Nothing
End Sub

補足

早速有難うございました。
　すみませんが、質問内容に不備があり、もう一度質問させていただきます。その際には、またよろしくお願いします。