27本目：ハイパーリンクのURL

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：ハイパーリンクのURL

#VBA100本ノック 27本目
WEBページからコピーしてシートに貼り付けたら、セルの文字列にハイパーリンクが付いてきました。
ハイパーリンクが付いているセルについて、
・右隣のセルにリンクのURLを出力
・ハイパーリンクを解除
※図は無視してください。
※対象シートは任意

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

' 100本ノック027：ハイパーリンクのURL
Sub ハイパーリンクを解除してURLを右セルへ抽出する()
    
    Dim ws対象シート As Worksheet
    Set ws対象シート = ActiveSheet
  
    ' ハイパーリンクがひとつでもある列の右に列を挿入
    Dim C As Long
    For C = Get最終列(ws対象シート) To 1 Step -1
    
        If ws対象シート.Columns(C).Hyperlinks.Count > 0 Then
            ws対象シート.Columns(C).Insert
        End If
        
    Next
    
    ' 各ハイパーリンクの横にURLを出力
    Dim HPリンク As Hyperlink
    For Each HPリンク In ws対象シート.Hyperlinks
        If HPリンク.Type = msoHyperlinkRange Then
            HPリンク.Range.Offset(, 1).Value = HPリンク.Address
        End If
    Next
    
    ' 全セルのハイパーリンクを解除
    ws対象シート.Hyperlinks.Delete
    
End Sub

汎用関数モジュール

Option Explicit

' 最終列の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終列を取得
    Get最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1

    ' 列が指定されていればその列の入力最終行を取得
    If R <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(R, Get最終列) = ""
            Get最終列 = Get最終列 - 1
            If Get最終列 < 対象セル範囲.Column Then
                Get最終列 = 0
                Exit Function
            End If
        Loop
    End If

End Function

解説

ハイパーリンクを操作する問題でした。

For Each文を回している途中でその対象をいじるのは怖いので、

• ハイパーリンクの削除は最後に一括で行う
• URL出力用の列は先に挿入しておく

という手順を踏んでいます。

肝心のFor Each文は大きく以下の2種類が存在します。

    ' ① すべてのハイパーリンクをループして親がRangeのものを処理
    Dim HPリンク As Hyperlink
    For Each HPリンク In ws対象シート.Hyperlinks
        If HPリンク.Type = msoHyperlinkRange Then

    ' ② すべてのセルをループしてハイパーリンクがあるものを処理
    Dim セル As Range
    For Each セル In ws対象シート.UsedRange.Cells
        If セル.Hyperlinks.Count > 0 Then

　
基本的にループの数が少ない方が高速ですので、本問では

• 列の挿入は列ごとに見ればいいので②を採用
• 実際の各ハイパーリンクへの処理は全セルを見たくないので①を採用

というロジックを採用しています。

といってもUsedRangeがよほど大きくなければ、どちらも大差ないと思います。
（もちろんUsedRangeを書かずに「In ws対象シート.Cells」にしてしまうとフリーズしますが）

イメージしやすい方で実装してみてください。