セル セルに設置されたハイパーリンクを取得

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit


Sub CellsHyperlinkGet()
'************************************
'セルに設置されたハイパーリンクを取得
'************************************
'・リンクの右隣に各プロパティに分けます
'・値・リンク数・リンク・サブアドレス
'・参照セルのリンクは削除します
'・リンク数文字に取得したリンクを設置

Dim sht As Worksheet
Dim i As Long
Dim Col As Long 'Columns
Dim Rng(5) As Range
Dim RangeValue As String
Dim HyperlinksCount As Long
Dim HyperlinkAddress As String
Dim HyperlinkSubAddress As String

Set sht = ThisWorkbook.Worksheets("Sheet1")

Col = 1 'リンク設置列
With sht
    For i = 1 To .Cells(65536, Col).End(xlUp).Row
        Set Rng(1) = .Cells(i, Col)     '参照セル
        Set Rng(2) = .Cells(i, Col + 1) '値
        Set Rng(3) = .Cells(i, Col + 2) 'リンク数
        Set Rng(4) = .Cells(i, Col + 3) 'リンク
        Set Rng(5) = .Cells(i, Col + 4) 'サブアドレス
        'セル値の取得
        RangeValue = Rng(1).Value
        Rng(2).Value = RangeValue
        'リンクの設置数取得
        HyperlinksCount = Rng(1).Hyperlinks.Count
        Rng(3).Value = HyperlinksCount
        If HyperlinksCount <> 0 Then '在れば
            'リンク取得
            HyperlinkAddress = Rng(1).Hyperlinks(1).Address
            Rng(4).Value = HyperlinkAddress
            'サブアドレス取得
            HyperlinkSubAddress = Rng(1).Hyperlinks(1).SubAddress
            Rng(5).Value = HyperlinkSubAddress
            'リンク設置
            .Hyperlinks.Add Rng(3), HyperlinkAddress
            'リンク削除
            Rng(1).Hyperlinks.Delete
        End If
        Set Rng(1) = Nothing
        Set Rng(2) = Nothing
        Set Rng(3) = Nothing
        Set Rng(4) = Nothing
        Set Rng(5) = Nothing
    Next i
End With

''【その他】
''図形 1 のハイパーリンク先をセル範囲 A1:B10 に設定します。
'    Worksheets(1).Shapes(1).Hyperlink.SubAddress = "A1:B10"
''図形 1 に接続されたハイパーリンク先の文書をロードします。
'    Worksheets(1).Shapes(1).Hyperlink.Follow NewWindow:=True
''図形は、ハイパーリンクを 1 つだけ持つことができます。
''図形 1 のハイパーリンクをアクティブにします。
'    Worksheets(1).Shapes(1).Hyperlink.Follow NewWindow:=True
''引数 index には、ハイパーリンク番号を指定します。
''セル範囲 A1:B2 のハイパーリンクをアクティブにします。
'    Worksheets(1).Range("A1:B2").Hyperlinks(2).Follow

End Sub

 

 

2000年01月01日|[VBサンプルコード]:[CELL]