指定のブックにシートが有るか確認したい。

Question

Cells(i,4) に以下のハイパーリンクを設定しました。

ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 4), Address:=Path & ".xlsx", SubAddress:=" '" & name & "'!A1", TextToDisplay:=name

このCells(i,4)のハイパーリンクを後から有効かチェックしたく、

①　Cells(i,4)のアドレスを抽出

②　Cells(i,4)のアドレスが有効か確認

の工程で、無効ならメッセージを入れたいのですが、以下のコードでうまく行きません。

Path = Cells(i, 4).Hyperlinks.Item(1).Address

 If Dir(Path) = "" Then
  MsgBox "リンクは無効です "
  Exit Sub
 End If

まず、「Path = Cells(i, 4).Hyperlinks.Item(1).Address」の部分ですが、ブックのパスは抽出できるのですが、シート名、セルの位置まで抽出することが出来ません。

ネット検索等で探したのですが、「セルから抽出したURLで他のブックに有るシートの有無を確かめる」という様なものを見つける事ができず、こちらで質問させていただきました。

よろしくお願いします。

Answer 1

Hyperlinks(1).SubAddress でシート名、セルの位置を取得できます。

Dir関数では、ブックの存在をチェックできますが、シートが存在するかどうかまではチェックできません。

ブックを開いてシートが存在するかチェックすればいいですが、
ご希望のことは開く前に有効かチェックしたいのですよね。

ExecuteExcel4Macroを使えば、開かずにセルの値を取得できます。

閉じたブックからデータを取得する：Excel VBA｜即効テクニック｜Excel VBAを学ぶならmoug

存在しないシートだとエラーになりますのでそれで開かずにチェックできます。
ただし、R1C1形式の外部参照式に変換する必要がありますので、なかなか面倒です。

コード例

Public Sub CheckHyperLink()
    Dim TargetCell As Range
    Set TargetCell = Cells(2, 4)    

    With TargetCell.Hyperlinks(1)
        Dim path As String, BookName As String
        path = .Address
        BookName = Dir(path)
        If BookName = "" Then
            MsgBox "リンクは無効です（存在しないブック） "
            Exit Sub
        End If

        Dim F As Variant
        F = "'" & Split(path, BookName)(0) & "[" & BookName & "]" & Mid(.SubAddress, 3)
        F = Application.ConvertFormula(F, xlA1, xlR1C1, xlAbsolute)
        If IsError(F) Then
            MsgBox "リンクは無効です"
            Exit Sub
        End If

        If IsError(ExecuteExcel4Macro(F)) Then
            MsgBox "リンクは無効です（存在しないシート） "
            Exit Sub
        End If
    End With

End Sub

Comments

[ice930]

ご回答ありがとうございます。
F = Application.ConvertFormula(F, xlA1, xlR1C1, xlAbsolute)
の部分ですが、エラー時のチェックをするために、セルにリンクされているシート名を変えて確認したところ、「型が一致しません」と表示されその先に進めません。
解決するのはどの様にすればよろしいでしょうか。

[hatena19]

そのコードに前に、
Debug.Print F
というコードを挿入して実行してみて、イミディエイトウィンドウに出力された文字列を教えてもらえますか。

[ice930]

シート名を変えた後のパスが表示されます。
'F:\作業用ﾃﾞｰﾀ\プラットフォーム作成用\書籍\書籍記録[記録(ネット).xlsx]ミニサイトつくって儲る法'!A1

ちなみに下が替える前です（問題なく動くやつです）
'F:\作業用ﾃﾞｰﾀ\プラットフォーム作成用\書籍\書籍記録[記録(ネット).xlsx]ミニサイトつくって儲ける法'!A1

[hatena19]

シート名自体に問題はなさそうですね。その文字列で試してみましたがエラーなく通りました。
原因は分かりませんが、とりあえず、
回答のコードを Application.ConvertFormula でエラーが出ても対応できるものに修正しましたので、それで試してみてください。

[ice930]

ありがとうございます！
　Exit　Function の所で、「SubまたはPropety内ではExit Functionをしようできません」と表示されてしまします。
試しにこの行のみを削除したところ、F = Application.ConvertFormula(F, xlA1, xlR1C1, xlAbsolute)で同様のエラーが発生し進まなくなってしましました。
順番など変えた方が良いでしょうか。

[hatena19]

Exit　Function を Exit Sub に修正してください。

[ice930]

ご指摘の部分と
If IsError(Application.ConvertFormula(F, xlA1, xlR1C1, xlAbsolute)) Then
に変更したら出来ました！
ありがとうございます！
ConvertFormulaなど、使ったことのないメソッドを使う事も出来、とても勉強になりました！！

Answer 2

SubAddressプロパティに設定したセル番地は、SubAddressプロパティにアクセスすることで取得できます。
https://docs.microsoft.com/ja-jp/office/vba/api/excel.hyperlink.subaddress

たとえば、質問文の例で言えば、

a = Cells(i, 4).Hyperlinks.Item(1).SubAddress

とすれば、SubAddressに設定されている値がaに取り出せます。

あとは、取得した"'Sheet1!A1'"という形式の文字列から、Find等を使って、シート名とセル番地を切り出し、
シートの存在を確認、
シートがなければエラーを出し、
シートがあれば、そのシートのセル番地の値を返すようにすればよいでしょう。

Comments

[ice930]

分かり易い回答ありがとうございました！
参考になりました！