Excel vba открыть ссылку в браузере - Word и Excel - помощь в работе с программами

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

Добрый день! Все решения по открыванию интернет-сайта по ссылке через VBA, которые я видел, открывают его в Internet Explorer. Ни для кого не секрет, что он загибается. Как открыть ссылку браузером по умолчанию или хотя бы MS Edge? Спасибо!

Dima S Пользователь Сообщений: 2063 Регистрация: 01.01.1970	что вы подразумеваете под «открыванием интернет-сайта по ссылке через VBA»? просто переход по ссылке через браузер или получение каких то данных в переменную?(при этом не обязательно показывать что либо пользователю)

Rigel44 Пользователь Сообщений: 69 Регистрация: 20.12.2014	Dima S, имею в виду открыть сайт в браузере Изменено: Rigel44 — 21.06.2020 23:14:38

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

21.06.2020 23:16:54

Сам отвечу на свой вопрос. Нашел на просторах интернета:

https://www.devhut.net/2018/02/01/vba-open-a-url-in-firefox-chrome/

Вроде работает, но может можно как-то попроще?
Также не разобрался, как добавить сюда Яндекс.Браузер
К тому же тут нужно выбирать браузер, а как открыть именно браузером по умолчанию, если не знаешь, какой у пользователя установлен браузер?

Код

Enum BrowserName    'This Enum is part of Sub OpenURL()
    InternetExplorer = 1
    FireFox = 2
    Chrome = 3
    Opera = 4
    Edge = 5
    Brave = 6
End Enum
 
 
'---------------------------------------------------------------------------------------
' Procedure : OpenURL
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Open a URL in FireFox
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sURL      : URL to open in FifeFox
'
' Usage:
' ~~~~~~
' Call OpenURL("http://www.google.ca", InternetExplorer)
' Call OpenURL("devhut.net", Chrome)
' Call OpenURL("msdn.com", FireFox)
' Call OpenURL("google.ca", Opera)
' Call OpenURL("http://www.google.ca", Edge)
' Call OpenURL("http://www.google.ca", Brave)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-11-13              Initial Release
' 2         2018-02-01              Updated Copyright under CC licensing
'                                   Error trapped FireFox not installed
' 3         2018-02-01              Complete revamp of the code to accomodate multiple
'                                   Browser
' 4         2020-04-27              Added Microsoft Edge
'                                   Added Brave
'---------------------------------------------------------------------------------------
Sub OpenURL(ByVal sURL As String, ByVal lBrowser As BrowserName)
    On Error GoTo Error_Handler
    Dim WSHShell              As Object
    Dim sFFExe                As String     'Executable path/filename
    Dim sProgName             As String     'Name of the Executable program
    Dim sExe                  As String     'Excutable exe filename
    Dim sCmdLineSwitch        As String     'Command line switch
    Dim sShellCmd             As String     'Shell Command
 
    'Determine the Path to FF executable
    Select Case lBrowser
        Case 1
            'https://msdn.microsoft.com/en-us/library/hh826025(v=vs.85).aspx
            sProgName = "Internet Explorer"
            sExe = "IEXPLORE.EXE"
            sCmdLineSwitch = " "
        Case 2
            'https://developer.mozilla.org/en-US/docs/Mozilla/Command_Line_Options#Browser
            sProgName = "Mozilla Firefox"
            sExe = "Firefox.EXE"
            sCmdLineSwitch = " -new-tab "
        Case 3
            sProgName = "Google Chrome"
            sExe = "Chrome.exe"
            sCmdLineSwitch = " -tab "
        Case 4
            'http://www.opera.com/docs/switches/
            sProgName = "Opera"
            sExe = "opera.exe"
            sCmdLineSwitch = " "
        Case 5
            sProgName = "Microsoft Edge"
            sExe = "Chrome.exe"
            sCmdLineSwitch = " -tab "
        Case 6
            sProgName = "Brave"
            sExe = "brave.exe"
            sCmdLineSwitch = " -tab "
    End Select
 
    If lBrowser = 5 Then    'Special case for Edge!  Thank you Microsoft for not following the rules!
        sShellCmd = "cmd /c """ & "start microsoft-edge:" & sURL & """"
    Else
        Set WSHShell = CreateObject("WScript.Shell")
        sFFExe = WSHShell.RegRead("HKEY_LOCAL_MACHINESOFTWAREMicrosoftWindows" & _
                                  "CurrentVersionApp Paths" & sExe & "")
        sFFExe = Replace(sFFExe, Chr(34), "")    'Special case for Opera?!
        'Open the URL
        sShellCmd = """" & sFFExe & """" & "" & sCmdLineSwitch & """" & sURL & """"
    End If
    shell sShellCmd, vbHide
 
Error_Handler_Exit:
    On Error Resume Next
    If Not WSHShell Is Nothing Then Set WSHShell = Nothing
    Exit Sub
 
Error_Handler:
    If Err.Number = -2147024894 Then
        MsgBox sProgName & " does not appear to be installed on this compter", _
               vbInformation Or vbOKOnly, "Unable to open the requested URL"
    Else
        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: OpenURL" & vbCrLf & _
               "Error Description: " & Err.Description & _
               Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
               , vbOKOnly + vbCritical, "An Error has Occurred!"
    End If
    Resume Error_Handler_Exit
End Sub

Изменено: Rigel44 — 21.06.2020 23:19:14

bedvit Пользователь Сообщений: 2477 Регистрация: 02.04.2015 Виталий	Через Shell не взлетает? «Бритва Оккама» или «Принцип Калашникова»?

Александр Моторин

Пользователь

Сообщений: 958
Регистрация: 31.12.2012

21.06.2020 23:40:13

Код

Public Declare Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal FileName As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long


'------------------------------------------------------------------------
' Open Webpage in default browser
'------------------------------------------------------------------------
Public Sub OpenUrl(strURL)
    Dim lSuccess As Long
    lSuccess = ShellExecute(0, "Open", strURL)
End Sub

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

21.06.2020 23:42:54

Александр Моторин, пробовал, у меня ничего не открывается, просто ничего не происходит. Что не так делаю?

Код

Public Declare Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal FileName As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long
 
 
'------------------------------------------------------------------------
' Open Webpage in default browser
'------------------------------------------------------------------------
Public Sub OpenUrl(strURL)
    Dim lSuccess As Long
    lSuccess = ShellExecute(0, "Open", strURL)
End Sub


Sub OpenUr()
    Call OpenUrl("https://yandex.ru")
End Sub

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

Уточняю. У меня не работало, когда браузер по умолчанию ставил Яндекс.Браузер, с другими браузерами работает. Но что не так с Яндекс.Браузером? Есть ли способ программно узнать, какой браузер стоит по умолчанию?

Изменено: Rigel44 — 22.06.2020 00:06:00

Игорь

Пользователь

Сообщений: 3631
Регистрация: 23.12.2012

22.06.2020 01:09:46

Всё намного проще.
Одна строка кода (открывающая ссылку в браузере по умолчанию)

Код
CreateObject("WScript.Shell").Run "https://ExcelVBA.ru/"

bedvit Пользователь Сообщений: 2477 Регистрация: 02.04.2015 Виталий	Я же про это и писал. Игорь спасибо за реализацию. «Бритва Оккама» или «Принцип Калашникова»?

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

Игорь, спасибо! Но еще раз повторюсь, метод работает не со всеми браузерами. При установке по умолчанию Яндекс.Браузер у меня выскакивает ошибка (прилагаю скрин). В других браузерах нормально, но все же, получается это не универсальное решение. Поэтому хочу программно узнать, какой браузер по умолчанию и если Яндекс — открывать, например, через Edge

Изменено: Rigel44 — 22.06.2020 23:13:45

Игорь

Пользователь

Сообщений: 3631
Регистрация: 23.12.2012

Это не ошибка макроса
Это у вас в системе (windows) что-то криво установлено

Макрос делает то же самое, что вы сделали бы вручную, нажав в Windows в меню ПУСК пункт ВЫПОЛНИТЬ, вставив туда ссылку, и кликнув на ОК
Это стандартный функционал Windows (она понимает, что это ссылка, и её нужно отправить в браузер по умолчанию)
Если же у вас этот макрос выдаёт ошибку (а этот макрос у меня проверен более чем на 10 тысячах разных компов),
то искать проблему надо не в макросе, а откатывать windows до того состояния, когда она умела открывать ссылки.

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#13

23.06.2020 07:44:52

Доброе время суток

Цитата
Rigel44 написал: Есть ли способ программно узнать, какой браузер стоит по умолчанию?

Проверил варианты

Windows RegKey — Default Browser Application Path

. В Windows 10 правильно записан Edge, в Window 7 Chrome. По найденному в ProgId идентификатору приложения в ветке HKEY_CLASSES_ROOTChromeHTMLshellopencommand вполне себе указан путь к браузеру по умолчанию. Дерзайте.

Андрей_26 Пользователь Сообщений: 647 Регистрация: 30.01.2018

Rigel44 Пользователь Сообщений: 69 Регистрация: 20.12.2014	Андрей VG, спасибо, это очень полезно! Но можно тупой вопрос, как залезть через VBA в произвольную ветвь реестра? Я умею только работать с ветвью VBA через GetSetting Изменено: Rigel44 — 23.06.2020 09:21:36

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#16

23.06.2020 10:04:46

Цитата
Rigel44 написал: как залезть через VBA в произвольную ветвь реестра?

Почитайте

, там и другого полезного не мало.

P. S. Медведь, а вот гранат не надо — палки будет достаточно

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

#17

23.06.2020 22:21:03

Андрей VG, здорово! спасибо!

Извините, снова вопросы. Почему вы написали ветку HKEY_CLASSES_ROOTChromeHTMLshellopencommand — у меня, например, Crome не установлен, поэтому и ветки такой нет. Да и почему в ветке хрома должен быть адрес браузера по умолчанию?
Смотрю ветку HKEY_CLASSES_ROOThttpshellopencommand — действительно, вижу адрес «C:Program FilesInternet ExplorerIEXPLORE.EXE» %1 , но у меня сейчас по умолчанию не IE стоит, а там адрес IE. В общем, не понимаю, уж простите ((

Что-то похожее нашел вот в этой ветке:

Код
HKEY_CURRENT_USERSoftwareMicrosoftWindowsShellAssociationsUrlAssociationshttpUserChoice

Значение переменной ProgId: YandexHTML.44X6GKC2M3EKCRFCQB634HVWGE

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#18

23.06.2020 22:48:26

Цитата
Rigel44 написал: Что-то похожее нашел вот в этой ветке:HKEY_CURRENT_USERSoftwareMicrosoftWindowsShellAssociationsUrlAssociationshttpUserChoice

Правильно ли я понимаю, что статью по ссылке вы не читали? Так как именно там указывалось посмотреть progId браузера по умолчанию в найденной вами ветке.

Забавно

Изменено: Андрей VG — 23.06.2020 23:16:25

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

Андрей VG, да, видимо поторопился. спасибо.
Сейчас начал «играться» с командами по чтению и записи из реестра при помощи объекта WshShell, в итоге в редакторе реестра исчезла ветка VBA (HKEY_CURRENT_USERSoftwareVB and VBA Program Settings), т.е. ее не видно в дереве. При этом пишет и читает программно без проблем. То же самое при попытке записать в другие папки тоже не отображаются никакие изменения, при этом программно все нормально читает. Такое ощущение, что реестр не обновляется больше, что это может быть???

RAN

Пользователь

Сообщений: 7091
Регистрация: 21.12.2012

#20

24.06.2020 17:44:11

Который день не могу понять, чем обычное

Код
ThisWorkbook.FollowHyperlink "https://www.planetaexcel.ru/"

не подходит?

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#21

24.06.2020 17:48:24

Цитата
RAN написал: не подходит?

А помучаться? А записать куда-нибудь что-нибудь,. чтобы всё пропало?

Цитата
Rigel44 написал: начал «играться» с командами по чтению и записи из реестра при помощи объекта WshShell

Надеюсь точку восстановления перед этим сделали? Читать читал реестр и через WshShell и через WMI, а вот запись делал только штатными VBA WriteSettings, поэтому ничего сказать и посоветовать не могу.

Rigel44

Пользователь

Сообщений: 69
Регистрация: 20.12.2014

#22

24.06.2020 20:45:04

Цитата
RAN написал: Который день не могу понять, чем обычноеКод ? 1ThisWorkbook.FollowHyperlink » https://www.planetaexcel.ru/ «не подходит?

Вот поэтому, у меня не работает:

Прикрепленные файлы

Скриншот 24-06-2020 204359.png (10.92 КБ)

Игорь

Пользователь

Сообщений: 3631
Регистрация: 23.12.2012

Вам уже второй простой проверенный код дали, из одной строки
Дальше будете искать коды и пробовать, или перечитаете то что я вам написал, насчёт сбоя в реестре из-за кривой установки браузера?
(и у вас после решения этой проблемы все эти макросы заработают без ошибок)

Юрий М

Модератор

Сообщений: 60570
Регистрация: 14.09.2012

Контакты см. в профиле

#24

24.06.2020 23:17:31

На всякий случай

Код

Sub qqq()
    x = Shell("""C:Program FilesInternet ExplorerIEXPLORE.EXE""" & """http://www.planetaexcel.ru""", vbNormalNoFocus)
    x = Shell("""C:Program FilesMozilla Firefoxfirefox.exe""" & """https://www.mail.ru""", vbNormalNoFocus)
    x = Shell("""C:Program FilesOperalauncher.exe""" & """https://www.planetaexcel.ru""", vbNormalNoFocus)
End Sub

Rigel44 Пользователь Сообщений: 69 Регистрация: 20.12.2014	#25 24.06.2020 23:31:02 Игорь, я переустанавливал браузер, ошибка не ушла. Поэтому сделал ее обход: если по умолчанию Яндекс, тогда запускается Edge, в остальных случаях по умолчанию. Я не знаю, проблема ли это моего компьютера или Яндекса, задача, чтобы сайт открывался, я ее решил. Всем спасибо за помощь!

Источник

If you want a more robust solution with ShellExecute that will open ANY file, folder or URL using the default OS associated program to do so, here is a function taken from http://access.mvps.org/access/api/api0018.htm:

'************ Code Start **********
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
Private Declare Function apiShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) _
    As Long

'***App Window Constants***
Public Const WIN_NORMAL = 1         'Open Normal
Public Const WIN_MAX = 3            'Open Maximized
Public Const WIN_MIN = 2            'Open Minimized

'***Error Codes***
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&

'***************Usage Examples***********************
'Open a folder:     ?fHandleFile("C:TEMP",WIN_NORMAL)
'Call Email app:    ?fHandleFile("mailto:dash10@hotmail.com",WIN_NORMAL)
'Open URL:          ?fHandleFile("http://home.att.net/~dashish", WIN_NORMAL)
'Handle Unknown extensions (call Open With Dialog):
'                   ?fHandleFile("C:TEMPTestThis",Win_Normal)
'Start Access instance:
'                   ?fHandleFile("I:mdbsCodeNStuff.mdb", Win_NORMAL)
'****************************************************

Function fHandleFile(stFile As String, lShowHow As Long)
Dim lRet As Long, varTaskID As Variant
Dim stRet As String
    'First try ShellExecute
    lRet = apiShellExecute(hWndAccessApp, vbNullString, _
            stFile, vbNullString, vbNullString, lShowHow)

    If lRet > ERROR_SUCCESS Then
        stRet = vbNullString
        lRet = -1
    Else
        Select Case lRet
            Case ERROR_NO_ASSOC:
                'Try the OpenWith dialog
                varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
                        & stFile, WIN_NORMAL)
                lRet = (varTaskID <> 0)
            Case ERROR_OUT_OF_MEM:
                stRet = "Error: Out of Memory/Resources. Couldn't Execute!"
            Case ERROR_FILE_NOT_FOUND:
                stRet = "Error: File not found.  Couldn't Execute!"
            Case ERROR_PATH_NOT_FOUND:
                stRet = "Error: Path not found. Couldn't Execute!"
            Case ERROR_BAD_FORMAT:
                stRet = "Error:  Bad File Format. Couldn't Execute!"
            Case Else:
        End Select
    End If
    fHandleFile = lRet & _
                IIf(stRet = "", vbNullString, ", " & stRet)
End Function
'************ Code End **********

Just put this into a separate module and call fHandleFile() with the right parameters.

Источник

How to open a website in the browser from Excel using a Macro and VBA.

This is the same as following a link or clicking a link from the worksheet except that it will be done through a Macro.

This does not open a website within Excel. Everything will still open in the browser.

The Macro

Here is the full macro that you need:


Sub Go_to_Website()
Dim ie As Object
Set ie = CreateObject("INTERNETEXPLORER.APPLICATION")
ie.NAVIGATE "http://www.google.com"



  


                       
  




ie.Visible = True
While ie.busy
 DoEvents
Wend
End Sub

This is a simple macro and it will open the website into Internet Explorer by default.

To use the macro, change http://www.google.com to whatever website you want the user to visit.

You can also replace this with a variable that holds the website url in order to make this a bit more versatile. In that case, you would just replace «http://www.google.com» with the desired variable name and without the double quotation marks around the variable name.

This is a fairly simple macro and you should not need to change anything other than what I just mentioned.

If you don’t know how to put this macro into Excel, you can read this tutorial here: Install a Macro into Excel

Make sure to download the sample file attached to this tutorial so you can get the macro ready to go in Excel.

Excel VBA Course — From Beginner to Expert

200+ Video Lessons
50+ Hours of Instruction
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

Subscribe for Weekly Tutorials

BONUS: subscribe now to download our Top Tutorials Ebook!

Excel VBA Course — From Beginner to Expert

200+ Video Lessons

50+ Hours of Video

200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

Источник

Открытие сайта методом Workbook.FollowHyperlink с помощью кода VBA Excel. Сокращенный синтаксис метода, примеры использования.

Метод Workbook.FollowHyperlink

FollowHyperlink – это метод объекта Workbook, позволяющий открыть сайт по указанному адресу в браузере, использующемуся по умолчанию.

Метод Workbook.FollowHyperlink предназначен для более широкого использования в VBA Excel, чем просто открытие сайтов. С полным описанием и всеми параметрами метода вы можете ознакомиться на сайте разработчика.

В этой же статье мы рассмотрим сокращенный синтаксис метода Workbook.FollowHyperlink с одним аргументом: адрес сайта.

Сокращенный синтаксис метода

Сокращенный синтаксис метода Workbook.FollowHyperlink представлен в VBA Excel двумя равнозначными вариантами:

Вариант 1

ThisWorkbook.FollowHyperlink Address:=«http://imya-sayta.ru/»

Вариант 2

ThisWorkbook.FollowHyperlink («http://imya-sayta.ru/»)

Примечания

1. Для сайтов на защищенном протоколе «https» можно указывать протокол «http», так как у защищенных сайтов есть переадресация с «http» на «https».

2. Если сайт по указанному адресу не существует, будет сгенерирована ошибка.

Примеры использования

Пример 1
Открытие сайта нажатием элемента управления Label на пользовательской форме VBA Excel:

‘Записываем адрес сайта

‘в заголовок метки Label1

Private Sub UserForm_Initialize()

With Label1

.Caption = «http://imya-sayta.ru/»

.Font.Size = 10

.Font.Underline = True

End With

End Sub

‘Переходим по гиперссылке

‘при нажатии на метку Label1

Private Sub Label1_Click()

On Error Resume Next

ThisWorkbook.FollowHyperlink _

Address:=Label1.Caption

End Sub

Выражение On Error Resume Next необходимо, чтобы корректно завершить процедуру при возникновении ошибки, когда указанный сайт не существует. Если хотите вывести сообщение об ошибке, используйте простой обработчик ошибок с оператором On Error GoTo.

Пример 2
Пример выбора сайта с помощью элемента управления ComboBox с автоматическим открытием гиперссылки и обработчиком ошибок:

‘Записываем адреса сайтов

‘в комбинированный список

Private Sub UserForm_Initialize()

With ComboBox1

.AddItem «http://sayt-1.ru/»

.AddItem «http://sayt-2.ru/»

.AddItem «http://sayt-3.ru/»

.AddItem «http://sayt-4.ru/»

.AddItem «http://sayt-5.ru/»

End With

End Sub

‘Переходим по гиперссылке

‘при выборе сайта в списке

Private Sub ComboBox1_Change()

On Error GoTo Stroka

ThisWorkbook.FollowHyperlink _

Address:=ComboBox1.Value

Exit Sub

Stroka:

If Err.Description <> «» Then

MsgBox «Произошла ошибка: « _

& Err.Description

End If

End Sub

Так как в списке из примера перечислены несуществующие сайты, при выборе одного из них, обработчик ошибок выведет следующее сообщение:

Источник

Этот макрос позволяет открыть в браузере все гиперссылки из выделенного диапазона ячеек.

Зачем нужен такой макрос, если можно щелкнуть на гиперссылке, и она так же откроется в браузере?

Некоторые гиперссылки могут быть неактивными, то есть в ячейку просто введен текст, содержащий ссылку
В этом случае придется вручную копировать содержимое ячейки, и вставлять в браузер
Гиперссылок может быть много, и щелкать на каждой из них — долго
Некоторые гиперссылки не открываются в браузере, и Excel выдаёт ошибку.
Причина этого: Excel сначала сам прогружает ссылку, и только если ему удалось прогрузить страницу, только после этого он отправляет её в браузер. Мало того что это иногда сильно увеличивает время открытия ссылок, так иногда и не даёт открыть некоторые рабочие ссылки, где на сайте нужна авторизация (или если ссылка не открывается в Internet Explorer, но открывается в современном браузере)

Скопируйте нижеприведённый код в свой файл Excel, а назначьте кнопке или комбинации клавиш макрос OpenHyperlinksInBrowser:

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

628 просмотров

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Источник