Как после ввода, автоматически менять интернет адрес на гиперссылку?

Категория: Basic

2012-08-21 14:47:08

Если Вы работаете с Excel 97, то возможно замечали, что в 8-й версии (в отличии от последующих) после ввода (или редактирования) текста, начинающегося с http:// , www. , ftp. , mailto: автоматического создания гиперссылок не происходит. Если такая ситуация неприемлема и Вам просто необходимо автоматизировать создание гиперссылок, причём только в определённом диапазоне, то выберите наиболее подходящий вариант, и разместите его в модуле нужного рабочего листа

Сокращённая версия (только ввод URL адресов, начинающихся с http:// или www.)

code: #vba

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

Поделиться:

Sample Code

категории

Как после ввода, автоматически менять интернет адрес на гиперссылку?

Похожие статьи: