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

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][セル セルに設置されたハイパーリンクを取得]
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





Production Japan Import Application. Since 1998