Макрос открытия гиперссылок в браузере

Sub OpenHyperlinksInBrowser()
    ' макрос открытия гиперссылок в браузере по умолчанию
    ' © 2022 ExcelVBA.ru
    On Error Resume Next
    Dim hl$, coll As New Collection, msg$, cell As Range, link, i&, cellValue$
 
    ' перебираем все непустые ячейки
    For Each cell In Intersect(ActiveSheet.UsedRange, Selection).Cells
        If Len(cell) Then
            ' считываем гиперссылку из ячейки
            hl$ = "": hl$ = GetCellHyperlinkAddress(cell, True)
 
            For i = 1 To 2000
                DoEvents ' пауза
            Next
            If hl$ Like "http*://?*.?*" Then coll.Add hl$
            If coll.Count > 20 Then Exit For ' ограничение на максимум 20 гиперссылок
        End If
    Next cell
 
    If coll.Count > 6 Then ' если выделено много ссылок - запрашиваем подтверждение
        msg$ = "Уверены, что хотите открыть в браузере сразу " & coll.Count & " ссылок?"
        If MsgBox(msg$, vbDefaultButton2 + vbOKCancel) = vbCancel Then Exit Sub
    End If
 
    For Each link In coll ' перебираем найденные ссылки
        CreateObject("WScript.Shell").Run link ' открываем ссылку link в браузере по умолчанию
    Next
End Sub
 
Function GetCellHyperlinkAddress(ByRef cell As Range, Optional AllowInactiveURL As Boolean = False) As String
    ' функция извлечения гиперссылки из ячейки
    ' поддерживаются активные и неактивные ссылки, и также формульные гиперссылки
    On Error Resume Next
    Dim v$
    With cell.MergeArea.Hyperlinks(1)
        GetCellHyperlinkAddress = .Address
        If Len(GetCellHyperlinkAddress) Then
            If Len(.SubAddress) Then GetCellHyperlinkAddress = GetCellHyperlinkAddress & "#" & .SubAddress
            Exit Function
        End If
    End With
    If AllowInactiveURL Then v$ = cell.Value: If InStr(1, v$, "://") > 0 Then If v$ Like "http*://?*.?*" Then GetCellHyperlinkAddress = v$: Exit Function
 
    Dim txt$, Brackets&, Quotes&, i&
    If GetCellHyperlinkAddress = "" Then
        If cell.Formula Like "=HYPERLINK*" Then
            txt$ = Mid$(cell.Formula, 12)
            txt$ = Left(txt, Len(txt) - 1)
            For i& = 1 To Len(txt)
                Select Case Mid(txt, i, 1)
                    Case "(": Brackets& = Brackets& + 1
                    Case ")": Brackets& = Brackets& - 1
                    Case """": Quotes& = Quotes& + 1
                    Case ","
                        If (Brackets& = 0) And (Quotes& Mod 2 = 0) Then
                            txt = Left(txt, i - 1)
                            Exit For
                        End If
                End Select
            Next
            GetCellHyperlinkAddress = Evaluate(txt)
        End If
    End If
    Err.Clear
End Function