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

質問

HohoPapa-さん
いつもいつもお世話になっております。
さて、以前同じ質問（2019/1/10）に下記のご回答を頂いて、今月に入って一覧表のリンク切れを修正すべく試してみたのですが、リンクが生きているのに「ファイルなし」とノイズがかなりの数発生しました。
ちなみに385件のファイル無しが抽出されますが、155件はリンクが生きていました。
(ご回答いただいた時点では、12月に表を配布した後だったのでいくつかのリンク切れを確認してうまくいくと思ってしまいました）

いつもながらの負んぶに抱っこの質問で恐縮ですが何か抽出精度を上げるアドバイスいただけたら幸いです。

1500件の表から385件の確認で済むのでこれでもかなりありがたいのですが。。。

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

回答No.3

HohoPapa · ベストアンサー

>文字列は具体的なフォルダ名なのでポストしにくい可能性大。
もし可能なら、
記号、半角スペース、全角スペースはそのまま置き換えず、
英数字は全角半角、大文字小文字が変わらないような別な英数字に、
全角文字は、適当な全角文字にそれぞれ置き換え、ポストしてみてください。

相当大きなネットワーク（ＬＡＮ，ＷＡＮ）が絡んでいるだろうことから
導入しているセキュリティに阻まれている可能性があるかもしれません。

お礼

急いだせいで大きな勘違い。
リンク無し、が有ったのですから、ファイルのフォルダ移動や削除ではなく、やはり何らかの原因が有ると考えるべきでした。

今少し原因を考えてみよう（＃No3)と思いますが、10/1500件なのであきらめるのは早いです。　御免なさい・・・

補足

度々のご回答ありがとうございます。（これも定型化しつつあり本当にすみません）

＃No2への補足コメントに書きましたが、逆つまり「リンクあり」の中の「リンク切れ」（約1000）はご勘弁、としていましたが、今回のマクロで抽出された295件の確認は改めてすべきかと・・・
バグった結果を正しい、として誤差（60件）と判断するのはいかがなものか？と思い
「知恵無きものは汗を出せ」ということで、先ほど295件のリンクを叩いてみました。

結果、なんと「リンク切無し」中のリンクあり（ノイズ）は10件でした。
個々の事情はパスを見ても不明ですが、対象データ約1500件中の10件なら本当に誰かが移動、削除してしまった可能性もありなので完全に大正解という事です。

汗をかく前に補足コメントしてしまったことを深く反省し、お詫びします。

＃No3でご指摘の試行は今度時間を見つけて実施してみますが。。。

補足コメントへのご回答前にと思い急ぎましたが、体力では知力に勝てず、申し訳ありませんでした。

取り急ぎここまで報告します。

回答No.2

HohoPapa

#1、HohoPapaです。

リンク先のファイルが、
マクロブック配置フォルダーとは別ドライブにある
あるいは、
ネットワーク上にある
といった場合は正常に動作しますが

リンク先のファイルが、
マクロブック配置フォルダーに同居
あるいは、
マクロブック配置フォルダーの下階層にある場合に
誤った判断をしているようです。（バグっています）

以下に改修後のコードをポストします。
テストしてみてください。　<m(__)m>

Sub LinkCheck()
　Dim Rowcnt As Long
　Dim wklink As String
　Dim chkDir 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
　　　　If ((Mid(wklink, 2, 2) <> ":\") And _
　　　　　　(Left(wklink, 2) <> "\\")) Then
　　　　　chkDir = ThisWorkbook.Path & "\" & wklink
　　　　Else
　　　　　chkDir = wklink
　　　　End If
　　　　Worksheets(2).Cells(Rowcnt, 4) = wklink
　　　　If FileExists(chkDir) = 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

補足

いつもながらの早々のご回答感謝です。
定型句になっていますが、「本当に感謝」です！

さて、結果報告ですが当初のマクロで検出された件数が385件、そのうち当方が手作業で確認したリンク切れが233件でした。逆「リンク有りの中の無し」は確認しておりませんがあしからず。<m(__)m>

今回のマクロで抽出された件数が295件となりました。
約60件の誤差が有りますが、385件を一気に確認したので当方の抜け、漏れの可能性もあり、正解率が60%から今回80%になったので今回はこれで十分です。（最初は正解率が低いのでしばらく放置状態でしたが、10件中2件程度と分かっていれば精神的なハードルは低いですので）

今後また誤差が大きくなるようなら再度質問させていただきますのでその節にはお見捨てなきようお願い致します。（誰かさんに怒られそうなお願いですが。。。。）

尚、＃No1でご質問の
＞このセルに期待通りのフルパスが埋まっているでしょうか？
ＮＧとなる文字列をサンプリングしてポストしてみてください。

に関しては、どのセルもパスの最後が「・・・pdf」になっていますのでフルパスが埋まっていると思います。
NGとなる文字列についてはこれから確認してみます。
文字列は具体的なフォルダ名なのでポストしにくい可能性大。

最後に今更ですが、目的のpdfファイルの保存場所は、全社のホストサーバ内の各工場、部署、担当者、製品別、等々深さ（パスの長さ）はマチマチで、その1つのフォルダーに私の保有しているpdfが有り、本マクロブックも同居してます。

長文になってしまったのでとりあえずここまでご報告させていただきます。

口癖ではなく「ありがとうございます！」

回答No.1

HohoPapa

拙作マクロ実行後、
Worksheets(2).Cells(Rowcnt, 4) = wklink
このセルに期待通りのフルパスが埋まっているでしょうか？
ＮＧとなる文字列をサンプリングしてポストしてみてください。

マクロは、
このセルに書き込まれる文字列（フルパス）のファイルにアクセスし、
ファイルのタイムスタンプを取得できるかどうかで判断しています。
まずは、この点を確認してください。

↑とおなじようなチェックとなりますが、スタートメニューから
ファイル名を指定して実行を選び
このセルに書き込まれる文字列（フルパス）を埋め
実行してみてください。