Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | Гиперссылки


Rambler's Top100


Counter CO.KZ


  1. Как программно создать гиперссылку ? 20.02.2007
  2. Как программно удалить все гиперссылки в нужном рабочем листе ? 31.03.2007
  3. Как программно создать кнопку на панели инструментов, которая будет действовать как гиперссылка ? 05.10.2007
  4. Как программно заменить текст всех гиперссылок на адреса ? 18.03.2011
  5. Как программно перебрать гиперссылки только в определённом диапазоне ? 11.04.2012
  6. Как заменить все адреса гиперссылок, содержащие ненужные URL на необходимый адрес ? 11.04.2012
  7. Как получить абсолютную гиперссылку из относительной (WinAPI) ? 13.04.2012
  8. Как программно создать относительную гиперссылку (WinAPI) ? 13.04.2012
  9. Как осуществить переход по гиперссылке с помощью клавиши ENTER ? 11.04.2012
  10. Как после ввода, автоматически менять интернет адрес на гиперссылку ? 30.09.2011
  11. Как получить или изменить базовый адрес гиперссылки текущей рабочей книги ? 15.04.2012
  12. Как отловить переход по гиперссылке и определить адрес ячейки с этой гиперссылкой ? 28.03.2012
  13. Как создать гиперссылку с помощью пользовательской функции ? NEW 08.04.2012

  • Ответ : Актуально для MS Excel 97, 2000, XP

    Вариант I, II, III.
  • With ThisWorkbook.Worksheets(1)
         .Hyperlinks.Add Anchor:=.Range("A1"), Address:="http://www.msoffice.nm.ru"
    End With
    With ThisWorkbook.Worksheets(1).Range("A3")
         .Hyperlinks.Add Anchor:=.Item(1), Address:="www.nm.ru"
    End With
    With ThisWorkbook.Worksheets(1).Range("A5")
         .Hyperlinks.Add Anchor:=.Cells(1), _
         Address:=Application.DefaultFilePath
    End With
    ThisWorkbook.Worksheets(1).Range("A7").Formula = "=HYPERLINK(""mailto:Klimov.Pavel@GMail.com"")"
    Если необходимо, чтобы в ячейке отображался не текст гиперссылки, а нужный текст, то :
    With ThisWorkbook.Worksheets(1)
         .Hyperlinks.Add Anchor:=.Range("A1"), Address:="http://www.nm.ru"
         .Range("A1").Value = "Проект Новая почта"
    End With
    With ThisWorkbook.Worksheets(1).Range("A3")
         .Hyperlinks.Add Anchor:=.Item(1), Address:="http://www.nm.ru"
         .Value = "Проект Новая почта"
    End With
    With ThisWorkbook.Worksheets(1).Range("A5")
         .Hyperlinks.Add Anchor:=.Cells(1), _
          Address:=Application.DefaultFilePath
         .Formula = "Просмотр содержимого папки"
    End With
    With ThisWorkbook.Worksheets(1).Range("A7").Formula = "=HYPERLINK(""http://www.msoffice.nm.ru"",""Может посетим ..."")"
    Особенности MS Excel 2000, XP
    В этих версиях, создать нужный текст, можно используя необязательный аргумент TextToDisplay :
    Worksheets(1).Hyperlinks.Add Anchor:=Range("C3"), _
    Address:="http://www.gramota.ru/", TextToDisplay:="Грамота.ру"

  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP
  • Private Sub DeleteAllHyperlinks()
        With ThisWorkbook.Worksheets(1)
             If Not .ProtectContents Then
                Dim iCell As Range: .Hyperlinks.Delete
                Set iCell = .UsedRange.Find(What:="=HYPERLINK(*)", _
                LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=True)
                Do Until iCell Is Nothing
                   iCell.Style = "Normal"
                   iCell.Value = iCell.Value
                   Set iCell = .UsedRange.FindNext
                Loop
             Else
                MsgBox "Снимите защиту листа", vbExclamation, ""
             End If
        End With
    End Sub
    Комментарий :
  • Удаление гиперссылок не приводит к удалению текста гиперссылок. Если такое положение вещей недопустимо, то используйте перебор всех гиперссылок, только учтите, что гиперссылка может быть связана не только с ячейкой, но и с автофигурой/рисунком.
  • Если гиперссылок, созданных с использованием стандартной функции рабочего листа =ГИПЕРССЫЛКА() может быть довольно много и/или Вы используете событие Worksheet_Change() (или аналогичное событие рабочей книги, приложения), а также Volatile функции, то в этом случае, имеет смысл использовать свойства ScreenUpdating, EnableEvents, Calculation об'екта Application. Пример их использования можно увидеть здесь.
  • Ответ :

    Для того, чтобы создать кнопку - гиперссылку, можно использовать нижеприведённый код, который желательно разместить в стандартном модуле.
  • Private Sub CreateButtonHyperlink()
        With Application.CommandBars(1).Controls.Add(Type:=msoControlButton)
             .FaceId = 2083
             .OnAction = "MyHyperlink"
             .Caption = "Microsoft Excel"
             .TooltipText = "Посетить сайт"
             .Style = msoButtonIconAndCaption
        End With
    End Sub

    Private Sub MyHyperlink()
        On Error Resume Next
        ThisWorkbook.FollowHyperlink _
        Address:="http://www.msoffice.nm.ru", NewWindow:=True
    End Sub
    Актуально только для MS Excel 2000, XP
    В этой версии, решить поставленную задачу, вполне можно и без использования макросов [FAQ] , но если создание такой кнопки это только часть задачи, где применение макросов действительно имеет смысл, то :
    Private Sub CreateButtonHyperlink_XP()
        With Application.CommandBars(1).Controls.Add(Type:=msoControlButton)
             .FaceId = 2083
             .Caption = "Microsoft Excel"
             .Style = msoButtonIconAndCaption
             .TooltipText = "http://www.msoffice.nm.ru"
             .HyperlinkType = msoCommandBarButtonHyperlinkOpen
        End With
    End Sub
    Примечание :
  • - В качестве примера выбрана стандартная панель инструментов ("Строка меню листа")
  • - Вместо номера/индекса панели Вы можете использовать её имя, и заменить (1) на ("Worksheet Menu Bar")
  • - При использовании этих примеров убедитесь, что панель инструментов не защищена [FAQ125]
  • Ответ : Актуально для MS Excel 97, 2000, XP
  • Private Sub HyperlinkReplaceValueOnAddress() 'Excel97 (и старше)
        Application.ScreenUpdating = False
        Dim iHyperlink As Hyperlink
        For Each iHyperlink In Worksheets(1).Hyperlinks
            If iHyperlink.Type = msoHyperlinkRange Then _
            iHyperlink.Range.Value = iHyperlink.Address '
        Next
        Application.ScreenUpdating = True
    End Sub
    Особенности MS Excel 2000, XP
    В этих версиях, заменить текст гиперссылки на её адрес, можно также используя необязательный аргумент TextToDisplay :
    Private Sub HyperlinkReplaceValueOnAddress2() 'Excel2000 (и старше)
        Application.ScreenUpdating = False
        Dim iHyperlink As Hyperlink
        For Each iHyperlink In Worksheets(1).Hyperlinks
            If iHyperlink.Type = msoHyperlinkRange Then _
            iHyperlink.TextToDisplay = iHyperlink.Address
        Next
        Application.ScreenUpdating = True
    End Sub
    Комментарий : Если рабочий лист + ячейки защищены, то Вы получите ошибку, которую можно избежать, если использовать данный совет [FAQ42] применительно к первому варианту.
  • Ответ : Актуально для MS Excel 97, 2000, XP
  • Private Sub objectHyperlink()
        Dim iSource As Range, iHyperlink As Hyperlink, iText$
        Set iSource = ThisWorkbook.Worksheets(1).Range("A1:C1000")
        
        For Each iHyperlink In iSource.Hyperlinks
            With iHyperlink
                 iText = "Cell Value : " & CStr(.Range.Value)
                 iText = iText & vbLf & "Name : " & .Name
                 iText = iText & vbLf & "Address : " & .Address
                 iText = iText & vbLf & "SubAddress : " & .SubAddress
                 'iText = iText & vbLf & "TextToDisplay : " & .TextToDisplay
                 'iText = iText & vbLf & "ScreenTip : " & .ScreenTip
                 iText = "В ячейке " & .Range.Address & _
                 " находится гиперссылка :" & String(2, 10) & iText
            End With
            MsgBox iText, , ""
        Next
    End Sub
    Комментарий :
  • Для того, чтобы перебрать гиперссылки, созданные с помощью стандартной функции рабочего листа =ГИПЕРССЫЛКА(), используйте поиск (т.е. методы Find и FindNext)
  • Да, и обратите внимание на то, что свойства TextToDisplay и ScreenTip появились только в Excel 2000
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Предположим, что во всех рабочих листах - текущей рабочей книги, нам необходимо найти все гиперссылки, адреса которых содержат ненужные URL ссылки, в данном примере, это URL поисковиков, которые, к сожалению, либо прекратили своё существование, либо приостановили свою деятельность, и заменить найденный адрес и текст в ячейке, на "http://www.yandex.ru" и "Яндекс. Найдётся всё", соответственно.
  • Private Sub ReplaceChooseHyperlinks()
        Dim iWorksheet As Worksheet, iHyperlink As Hyperlink, iArray
        
        iArray = Array("turtle.ru", "punto.ru", "webfind.ru")
        
        With Application
             .ScreenUpdating = False
             .EnableEvents = False
             .Calculation = xlManual
             For Each iWorksheet In ThisWorkbook.Worksheets
                 For Each iHyperlink In iWorksheet.Hyperlinks
                     If .Count(.Search(iArray, iHyperlink.Address)) Then
                        iHyperlink.Address = "http://www.yandex.ru"
                        If iHyperlink.Type = msoHyperlinkRange Then
                           iHyperlink.Range.Value = "Яндекс. Найдётся всё"
                           'iHyperlink.TextToDisplay = "Яндекс. Найдётся всё"
                        End If
                     End If
                 Next
             Next
             .Calculation = xlAutomatic
             .EnableEvents = True
             .ScreenUpdating = True
        End With
    End Sub
    Комментарий :
  • Если рабочий лист + ячейки защищены, то при использовании Range.Value Вы получите ошибку, которую можно избежать, если использовать данный совет [FAQ42]
  • Для того, чтобы перебрать гиперссылки, созданные с помощью стандартной функции рабочего листа =ГИПЕРССЫЛКА(), используйте поиск (т.е. метод Find и FindNext)
  • Ответ : Актуально для MS Excel XP (и старше)

    Если активная ячейка содержит гиперссылку, то в Excel 97, 2000 переход по гиперссылке можно осуществить, просто нажав клавишу ENTER, в следующих же версиях, такая возможность исчезла, и если Вы хотите её вернуть, то скопируйте в любой стандартный модуль личной книги макросов "Personal.xls" нижеприведённый код и сохраните изменения :
  • Private Sub Auto_Open()
        Application.OnKey "~", "FollowHyperlink"
        Application.OnKey "{ENTER}", "FollowHyperlink"
    End Sub
    
    Private Sub FollowHyperlink()
        If Not TypeOf Selection Is Range Then Exit Sub
           
        If ActiveCell.Hyperlinks.Count = 0 Then
           If Not Application.MoveAfterReturn Then Exit Sub
           
           Select Case Application.MoveAfterReturnDirection
               Case xlDown:    SendKeys "{DOWN}"
               Case xlToLeft:  SendKeys "{LEFT}"
               Case xlToRight: SendKeys "{RIGHT}"
               Case xlUp:      SendKeys "{UP}"
           End Select
        Else
           On Error Resume Next
           ActiveCell.Hyperlinks(1).Follow 'NewWindow:=True
        End If
    End Sub
    Комментарий : Этот вариант не будет работать с гиперссылками, созданными с помощью стандартной функции рабочего листа =ГИПЕРССЫЛКА()
  • Ответ : Актуально для MS Excel 97

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

    Сокращённая версия (только ввод URL адресов, начинающихся с http:// или www.)
  • 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
    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
    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@mail.ru , mailto:admin@xxx.ru)
    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

  • Ответ : Актуально для MS Excel 97, 2000, XP

    Для того, чтобы с помощью VBA, получить или изменить путь/адрес, который Excel использует для создания относительных гиперссылок (и который можно увидеть/изменить вручную, если в меню Файл выбрать команду Свойства, затем выделить закладку Документ и работать с текстовым полем База гиперссылки), достаточно применить следующий синтаксис, разумеется, указав нужную рабочую книгу.
  • iPath = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base")
    If iPath <> "" Then
       MsgBox "База гиперссылки: " & iPath, ,""
    Else
       MsgBox "На нет, и суда нет", ,""
    End If
    Комментарий : Обратите внимание на то, что в случае отсутствия базы гиперссылки, гиперссылки, типа, file:// могут создаваться относительно папки, в которой находится текущая книга (естественно, если она сохранена)
    iPath = "C:\Мои документы"
    ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") = iPath
    iAddress = "http://www.microsoft.com"
    ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") = iAddress

  • Ответ : Актуально для MS Excel 2000, XP

    Для того, чтобы отловить клик мышкой (или нажатие клавиши ENTER в Excel 2000) по гиперссылке, а также определить адрес ячейки с этой гиперссылкой, можно использовать нижеприведённое событие, которое необходимо разместить в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
        Dim iCell As Range
        Set iCell = Target.Range 'Target.Parent
        MsgBox iCell.Address
    End Sub
    Примечание : К сожалению, данное событие не позволяет отловить переход по гиперссылкам, которые связаны с автофигурой/рисунком, или созданы с помощью стандартной функции рабочего листа =ГИПЕРССЫЛКА(), впрочем, есть обходные решения, которые появятся позже ...
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

    © 2004-2013 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff