Автоматически менять интернет адрес на гиперссылку — Visual Basic(Бейсик)

Option Compare Text
 
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range
    Set iSource = Intersect(Target, [A2:A100])
    If Not iSource Is Nothing Then
       For Each iCell In iSource
           If iCell.Text Like "www.*" Then
              Hyperlinks.Add Anchor:=iCell, Address:="http://" & iCell
           ElseIf iCell.Text Like "http://*" Then
              Hyperlinks.Add Anchor:=iCell, Address:=iCell
           End If
       Next
    End If
End Sub
code: #vba
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range
    Set iSource = Intersect(Target, [A2:A100])
    If Not iSource Is Nothing Then
       For Each iCell In iSource
           If InStr(1, iCell, "www.", vbTextCompare) = 1 Then
              Hyperlinks.Add Anchor:=iCell, Address:="http://" & iCell
           ElseIf InStr(1, iCell, "http://", vbTextCompare) = 1 Then
              Hyperlinks.Add Anchor:=iCell, Address:=iCell
           End If
       Next
    End If
End Sub
code: #vba
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range, iText$
    Set iSource = Intersect(Target, [A2:A100])
    If Not iSource Is Nothing Then
       If Application.Sum(Application.CountIf( _
          iSource, Array("http://*", "www.*"))) = 0 Then
          'MsgBox "В этом диапазоне нет URL адресов", vbInformation, ""
          Exit Sub
       End If
       For Each iCell In iSource
           iText = LCase(CStr(iCell))
           Select Case True
               Case iText Like "www.*"
               Hyperlinks.Add Anchor:=iCell, Address:="http://" & iText
               Case iText Like "http://*"
               Hyperlinks.Add Anchor:=iCell, Address:=iText
           End Select
       Next
    End If
End Sub
Полная версия (включает также создание гиперссылок, типа info@samplecode.ru , mailto:admin@samplecode.ru)

code: #vba
Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'XL97
    Dim iSource As Range, iCell As Range, iAddress$
    Set iSource = Intersect(Target, Me.[A2:A100])
    If iSource Is Nothing Then Exit Sub
 
    iArrPrefix = Array("http://*", "ftp.*", "www.*", "mailto:*", "*@*.*")
    With Application
         If .Sum(.CountIf(Target, iArrPrefix)) = 0 Then Exit Sub
         '.ScreenUpdating = False
         For Each iCell In iSource
             iIndexPrefix = .Match(1, .CountIf(iCell, iArrPrefix), 0)
             If Not IsError(iIndexPrefix) Then
                iAddress = Choose(iIndexPrefix, "", _
                "ftp://", "http://", "", "mailto:") & iCell.Value
                Me.Hyperlinks.Add Anchor:=iCell, Address:=iAddress
             End If
         Next
         '.ScreenUpdating = True
    End With
End Sub