セル セルに設置されたハイパーリンクを取得
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
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 |