Функція пошуку доступна з контекстного меню осередків:
Як ви можете бачити на скріншоті, є можливість вибору браузера.
На вибір представлені найбільш популярні браузери: Internet Explorer, Mozilla Firefox, Opera, іGoogle Chrome.
У макрос навмисно введено обмеження на кількість осередків, текст з яких можна одномоментно запустити в пошук.
Якщо кількість унікальних непустих значень в виділених осередках перевищить 20, пошук буде скасований,
а користувач побачить повідомлення з попередженням:
Код (див. Приклад в прикріпленому файлі) складається з 2 макросів.
Макрос CreateItemsInCellContextMenu запускається автоматично, при кожному натисканні правою кнопкою миші на аркуші,
і додає нові пункти в контекстне меню комірки.
Макрос SearchValuesInWeb запускається, коли ви натискаєте на одному з доданих в меню пунктів,
визначає, в якому браузері треба його шукати, та запускає пошук кожного значення з виділеного діапазону.
Всім доброго дня. Викладаю код, щоб запускати макрос з надбудови або кнопкою (макрос на створення меню прибраний).
Sub SearchValuesInWeb ()
Dim Link $
'Макрос відкриває в обраному браузері результати пошуку значень з осередків
'Пошук проводиться в Google
If Err Then Exit Sub 'запуск не з контекстного меню
maxCellsCount = 10 'більше 20 осередків - відмовляємося від запуску пошуку
Dim coll As New Collection
'Беремо тільки непусті унікальні значення з виділеного діапазону комірок
Dim ra As Range: Set ra = Intersect (Selection, ActiveSheet.UsedRange)
Arr = ra.Value: If ra.Cells.Count = 1 Then Arr = Array (ra (1))
For Each Item In Arr
If Len (Trim (Item)) Then coll.Add CStr (Trim (Item)), CStr (Trim (Item))
If coll.Count> maxCellsCount Then Exit For
Next
'Якщо випадково запустити пошук тисячі значень - комп підвисне надовго.
If coll.Count> maxCellsCount Then
msg = "Кількість значень для пошуку провисіло обмеження в" maxCellsCount "Осередків!"
MsgBox msg, vbExclamation, "Забагато строк - пошук скасовується"
Exit Sub
End If
'Формуємо шлях до обраного браузеру (в реєстрі потрібну інформацію викопати складно.)
'Не факт, що бидет працювати на всіх комп'ютерах (програми могли бути встановлені в інші папки)
Path $ = "" "" "C: \ Program Files (x86) \ Google \ Chrome \ Application \ chrome.exe" "" ""
'Перевіряємо існування виконуваного файлу браузера
Path2 $ = Path $: If Dir (Split (Path $, Chr (34)) (1), vbNormal) = "" Then Path2 $ = ""
Так можна.
Такі рішення я зараз роблю на базі надбудови «Парсер сайтів»
Привіт, а можна здійснити пошук не в Гуглі, а на конкретному сайті?
Вітаю!
Скажіть, а чи можна через макрос синхронізувати поточну дату по інтернету.
Хочу задати обмеження на роботу програми за поточною датою.
Зараз код виглядає так:
Private Sub Workbook_Open ()
Else
Sheets ( "Лист1"). Select
ActiveSheet.Cells (1, 1) .Value = 0
де значення Cells (1, 1) припиняє дію програми.
Але це дуже просто обійти-всього лише змінюємо дату в календарі виндовс. Як бути?
Код не працює з деякими символами.
Якщо пошук ведеться по тексту виду
текст1 | Текст2
тобто використовуючи логічний оператор АБО
Підкажіть чим це може бути пов'язано? Навіть якщо ми міняємо символ | на% 7с - все одно не хоче.
Спасибі большай вам за корисний ресурс.
Своє завдання вирішив, але я незнаю чи правильно технічно вона вирішена, але тим немение працюю на 100%
Sub CreateItemsInCellContextMenu ()
On Error Resume Next
PopularBrowsers = Array ( "2gis maps", "Yandex maps", "Google maps", "Yandex", "Google")
Application.CommandBars ( "cell"). Reset 'скидання контекстного меню осередків
Application.CommandBars ( "cell"). Controls (1) .BeginGroup = True 'риска над першим пунктом меню
'Додаємо пункти в контекстне меню осередків
With Application.CommandBars ( "cell"). Controls.Add (10. 1)
.Caption = "Шукати на."
'Додаємо підпункти в меню
For Each browser In PopularBrowsers 'для кожного браузера - свій підпункт меню
With .Controls.Add (1. 1) 'додаємо пункт меню
.OnAction = "SearchValuesInWeb" 'призначаємо кнопці макрос SearchValuesInWeb
.Caption = browser. Tag = browser 'у властивості TAG запам'ятовуємо назву браузера
End With
Next
End With
End Sub
Sub SearchValuesInWeb ()
'Макрос відкриває в обраному браузері результати пошуку значень з осередків
'Пошук проводиться в Google
On Error Resume Next: Err.Clear
browser $ = Application.CommandBars.ActionControl.Tag 'читаємо параметр з властивості TAG
If Err Then Exit Sub 'запуск не з контекстного меню
maxCellsCount = 20 'більше 20 осередків - відмовляємося від запуску пошуку
Dim coll As New Collection
'Беремо тільки непусті унікальні значення з виділеного діапазону комірок
Dim ra As Range: Set ra = Intersect (Selection, ActiveSheet.UsedRange)
arr = ra.Value: If ra.Cells.Count = 1 Then arr = Array (ra (1))
For Each Item In arr
If Len (Trim (Item)) Then coll.Add CStr (Trim (Item)), CStr (Trim (Item))
If coll.Count> maxCellsCount Then Exit For
Next
'Якщо випадково запустити пошук тисячі значень - комп підвисне надовго.
If coll.Count> maxCellsCount Then
msg = "Кількість значень для пошуку провисіло обмеження в" maxCellsCount "Осередків!"
MsgBox msg, vbExclamation, "Забагато строк - пошук скасовується"
Exit Sub
End If
Якщо готовий код потрібен, - завжди можете оформити замовлення на доопрацювання коду під ваші потреби.
Або на форумі з Excel ви задавали це питання, - там напевно вам вже допомогли з вирішенням.