エクセルシートの無効リンクの確認

質問

いつもお世話になっております。
以前同じ質問をさせてもらったところ、別の方から回答頂いた下記のコードで動作確認できたのでBSを選んで締め切ったのですが、何度か使用していて抜けが有ることに気付きました。
前回の質問時にHohoPapaさんから「実際の表を添付すればさほど難しいコードではないでしょう」と言われたのですが質問中の図の添付方法が分からないまま、上記のように解決したと思ってしまいました。

下記のコードは当該シートで動いて2番目のSheetに結果が表示されるのですが、何故か検索対象範囲が半分以上漏れているようです。（2番目の結果表のA列のデータ数が明らかに少ない）
表示されている結果は正しくリンクが切れているのですが、検索した件数が足りていないことに気付きました。

やりたいことは、SheetのD列の品名にその製品の仕様書(pdf)にリンクが貼ってあるのですが仕様書は多数の部署の人がメンテするのでファイルが削除されたり移動されることもあるので定期的にリンクを更新（確認）する必要があります。

今回は画像を添付しますので宜しくお願いします。

Sub Sample()
　　For i = 1 To Worksheets(1).Hyperlinks.Count
　　　　With Worksheets(1).Hyperlinks(i)
　　　　　　Worksheets(2).Cells(i, 1) = .Range.Address
　　　　　　Worksheets(2).Cells(i, 2) = .Address
　　　　　　Worksheets(2).Cells(i, 3) = Dir(.Address)
　　　　End With
　　Next i
End Sub

回答No.1

HohoPapa · ベストアンサー

なにやら、私の名前が登場していますが、私がポストしたコードでしたっけ？

ともあれ、次のようなコードを提案します。
よかったら試してみてください。

Option Explicit

'//　リンク状況確認
Sub LinkCheck()
　Dim Rowcnt As Long
　Dim wklink As String
　With ThisWorkbook.Sheets(1)
　　Rowcnt = 2
　　Do
　　　If .Cells(Rowcnt, 4).Value = "" Then Exit Do
　　　Worksheets(2).Cells(Rowcnt, 1) = .Cells(Rowcnt, 4).Value
　　　Worksheets(2).Cells(Rowcnt, 2) = .Cells(Rowcnt, 4).Address
　　　If .Cells(Rowcnt, 4).Hyperlinks.Count > 0 Then
　　　　wklink = .Cells(Rowcnt, 4).Hyperlinks(1).Address
　　　　Worksheets(2).Cells(Rowcnt, 4) = wklink
　　　　If FileExists(wklink) = True Then
　　　　　Worksheets(2).Cells(Rowcnt, 3) = "ファイルあり"
　　　　Else
　　　　　Worksheets(2).Cells(Rowcnt, 3) = "ファイル無し"
　　　　End If
　　　Else
　　　　　Worksheets(2).Cells(Rowcnt, 3) = "リンク未設定"
　　　End If
　　　Rowcnt = Rowcnt + 1
　　Loop
　End With
End Sub

'//　ファイル有無判定関数
Function FileExists(ChkFile As String) As Boolean
　FileExists = True
　On Error GoTo ErrorHandler　　　　 ' エラー処理ルーチンを定義
　FileDateTime (ChkFile)
　On Error GoTo 0　　　　　　　　　　' エラーのトラップを無効にします。
　Exit Function　　　　　　　　　　　' エラー処理ルーチンが実行されないように Sub を終了
ErrorHandler:　　　　　　　　　　　　' エラー処理ルーチン
　FileExists = False
　Resume Next
End Function

お礼

昨夜リストの結果を検証して間違いないことを確認しました。
特定の部署のフォルダーが一式抜けていることが分かりました。
恐らくフォルダーを移動させたと思われます。

この業務は最近引き受けたものでメンテの方法が見えました。

前回のご回答を含め、改めて感謝！＆お礼申し上げます。

補足

早々のご回答、試してみて驚きの結果です。
なんと1発で全997件の検索結果が、しかも希望通りのリスト表記で得られました。（やはり多くのファイルが移動、削除されていました）
詳細な検証結果はこれからやりますのでBS（締め切り）はそれからにさせて頂きます。（当方の場合何か起こると対処できないレベルですので）

●質問にアップしたコードは
＞別の方から回答頂いた下記のコードで動作確認できたのでBSを選んで締め切った・・・
ということでHohoPapaさんではありません。
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＜別件＞
先日教えて頂いた、”エクセルシートをpdfファイルで添付して、メールを起動させる”、というコードは試行してみて動かなかったので、「当方には難しすぎて使えそうもない」とギブアップ宣言してあきらめたのですが、その後良くヨク見て、どうもセル番地が（1,1）(1,2)となっているようなので、無駄と思いながら試しに所定のセルの行,列を入れて見たところ、なんと目的の結果が得られ、ビックリX2しました。

定型書式が多いのでセル番地が同じなので、シート名に関係なく全シートで使えるのは本当に有用です。
ワードからのコードのコピペで他ファイルへの適用が可能！

しかし、補足欄もお礼欄も使ってしまっていましたので、この場をお借りして改めて御礼申し上げます。（これが今回指名させて頂いた理由の1つでもあります）

お手数をお掛けしました。
今後ともよろしくお願い致します。（長々と失礼）