mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Поиск в Google значений из ячеек листа Excel

Макрос для поиска текста выделенных ячеек в Google

Макрос предназначен для поиска текста из выделенных ячеек в поисковой системе Google.

Функция поиска доступна из контекстного меню ячеек:

добавление пункта поиска в контекстное меню ячеек Excel

Как вы можете видеть на скриншоте, есть возможность выбора браузера.
На выбор представлены наиболее популярные браузеры: Internet Explorer, Mozilla Firefox, Opera, и Google Chrome.

 

В макрос намеренно введено ограничение на количество ячеек, текст из которых можно одномоментно запустить в поиск.

Если количество уникальных непустых значений в выделенных ячейках превысит 20, поиск будет отменён,
а пользователь увидит сообщение с предупреждением:

предупреждение  о превышении допустимого количества ячеек

 

Код (см. пример в прикреплённом файле) состоит из 2 макросов.

Макрос CreateItemsInCellContextMenu запускается автоматически, при каждом щелчке правой кнопкой мыши на листе,
и добавляет новые пункты в контекстное меню ячейки.

 

Sub CreateItemsInCellContextMenu()
    On Error Resume Next
    PopularBrowsers = Array("Internet Explorer", "Mozilla Firefox", "Opera", "Google Chrome")
 
    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
 
    ' отдельный пункт - для поиска в браузере, установленном в системе по-умолчанию
    With Application.CommandBars("cell").Controls.Add(1, , , 1)
        .OnAction = "SearchValuesInWeb"    ' назначаем кнопке макрос SearchValuesInWeb
        .Caption = "Искать в Google в браузере по-умолчанию"
    End With
End Sub

 

Макрос SearchValuesInWeb запускается, когда вы щелкаете на одном из добавленных в меню пунктов,
определяет, в каком браузере надо выполнить поиск, и запускает поиск каждого значения из выделенного диапазона.

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
 
    ' формируем путь к выбранному браузеру (в реестре нужную информацию выкопать сложно...)
    ' не факт, что быдет работать на всех компах (программы могли быть установлены в другие папки)
    Select Case browser$    ' "Internet Explorer", "Mozilla Firefox", "Opera", "Google Chrome"
        Case "Internet Explorer"
            Path$ = """" & Environ("ProgramFiles") & "\Internet Explorer\IEXPLORE.EXE" & """"
        Case "Mozilla Firefox"
            Path$ = """" & Environ("ProgramFiles") & "\Mozilla Firefox\firefox.exe" & """ -new-tab "
        Case "Opera"
            Path$ = """" & Environ("ProgramFiles") & "\Opera\opera.exe" & """"
        Case "Google Chrome"
            Path$ = """" & Environ("USERPROFILE") & "\Local Settings\Application Data\" _
                    & "Google\Chrome\Application\chrome.exe" & """"
    End Select
 
    ' проверяем существование исполняемого файла браузера
    Path2$ = Path$: If Dir(Split(Path$, Chr(34))(1), vbNormal) = "" Then Path2$ = ""
 
    For Each Item In coll    ' перебираем все уникальные значения ячеек
        ' формируем поисковую ссылку для Google
        n = n + 1: link$ = """" & "http://www.google.ru/search?hl=ru&newwindow=1&q=" & Item & """"
 
        If browser$ = "" Then    ' открываем ссылку в браузере "по-умолчанию"
            CreateObject("wscript.shell").Run link$
 
        Else    ' запускаем нужный браузер
            If Len(Path2$) Then    ' если exe-файл нужного браузера найден, то
                ' запускаем браузер для открытия ссылки
                CreateObject("wscript.shell").Run Path$ & " " & link$
            Else
                ' выводим сообщение, что браузер не найден
                Debug.Print "Browser " & browser$ & " not found: " & Path$
            End If
        End If
 
        ' после первой ссылки дожидаемся запуска браузера (1 секунду)
        If n = 1 Then Application.Wait Now + 1 / 86400
    Next
End Sub

ВложениеРазмерЗагрузкиПоследняя загрузка
SearchInWeb.zip18.44 КБ22 года 36 недель назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Да, конечно можно.
Очень много сайтов, где можно получить текущую дату (как макросом, так и обновляемым веб-запросом)
Например, можно сделать запрос котировок валют на сайт любого банка - там есть дата (примеров в интернете много)
Или найдите любой другой сайт, где выводится дата, - например, этот: http://time.jp-net.ru/

Здравствуйте!
Скажите, а можно ли через макрос синхронизировать текущую дату по интернету.
Хочу задать ограничение на работу программы по текущей дате.
Сейчас код выглядит так:

Private Sub Workbook_Open()

If Date < 42005 Then

Else
Sheets("Лист1").Select
ActiveSheet.Cells(1, 1).Value = 0

End If

End Sub

где значение 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

' формируем путь к выбранному браузеру (в реестре нужную информацию выкопать сложно...)
' не факт, что быдет работать на всех компах (программы могли быть установлены в другие папки)
Select Case browser$ ' "Internet Explorer", "Mozilla Firefox", "Opera", "Google Chrome"
Case "2gis maps"
For Each Item In coll ' перебираем все уникальные значения ячеек
' формируем поисковую ссылку для Google
link$ = """" & "http://2gis.ru/#!/odessa/center/30.711727%2C46.461917/zoom/11/state/firms/what/" & Item & "/action/search/page/1/sort/relevance/rpage/1/ppage/1" & """"
' открываем ссылку в браузере "по-умолчанию"
CreateObject("wscript.shell").Run link$
Next
Case "Yandex maps"
For Each Item In coll ' перебираем все уникальные значения ячеек
' формируем поисковую ссылку для Google
link$ = """" & "http://maps.yandex.ua/?text=" & Item & """"
' открываем ссылку в браузере "по-умолчанию"
CreateObject("wscript.shell").Run link$
Next
Case "Google maps"
For Each Item In coll ' перебираем все уникальные значения ячеек
' формируем поисковую ссылку для Google
link$ = """" & "http://maps.google.com/?q=" & Item & """"
' открываем ссылку в браузере "по-умолчанию"
CreateObject("wscript.shell").Run link$
Next
Case "Yandex"
For Each Item In coll ' перебираем все уникальные значения ячеек
' формируем поисковую ссылку для Google
link$ = """" & "http://yandex.ru/yandsearch?text=" & Item & """"
' открываем ссылку в браузере "по-умолчанию"
CreateObject("wscript.shell").Run link$
Next
Case "Google"
For Each Item In coll ' перебираем все уникальные значения ячеек
' формируем поисковую ссылку для Google
link$ = """" & "http://www.google.ru/search?hl=ru&newwindow=1&q=" & Item & """"
' открываем ссылку в браузере "по-умолчанию"
CreateObject("wscript.shell").Run link$
Next
End Select
End Sub

Если готовый код нужен, - всегда можете оформить заказ на доработку кода под ваши нужды.
Или на форуме по Excel вы задавали этот вопрос, - там наверняка вам уже помогли с решением.

Превосходно, этому тоже найдется 100 % применение, спасибо Вам.
Но я не правильно выразился, уточню. Нужно чтобы поиск осуществлялся для каждой поисковой системы отдельно, то есть нужно искать в гугле то жмем кнопку поиск в гугле, нужно для яндекса тогда жмем кнопку поиск в яндексе.
И тоже важный факт, желательно чтобы эти кнопки поисковых систем скрывались в дополнительном выпадающем списке, то есть там где сейчас перечень браузеров, так как список поисковых систем будет большой, поэтому чтобы не увеличивать контекстное меню эти списки нужно прятать.
Спасибо

Примерно так будет (для 2 поисковых систем в браузере по-умолчанию)

Sub SearchValuesInWeb()        ' поиск производится в Google и Яндекс
    On Error Resume Next: Err.Clear
    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
 
    For Each Item In coll        ' перебираем все уникальные значения ячеек
        ' формируем поисковую ссылку для Google
        link$ = """" & "http://www.google.ru/search?hl=ru&newwindow=1&q=" & Item & """"
        ' открываем ссылку в браузере "по-умолчанию"
        CreateObject("wscript.shell").Run link$
 
        ' формируем поисковую ссылку для Яндекс
        link$ = """" & "http://yandex.ru/yandsearch?text=" & Item & """"
        ' открываем ссылку в браузере "по-умолчанию"
        CreateObject("wscript.shell").Run link$
    Next
End Sub

Подскажите пожалуйста, как сделать чтобы данный макрос открывал не в разных браузерах а в разных поисковых системах с помощью браузера по умолчанию ?

Знаете, ничего не помогало.
Но методом научного тыка определилось решение - надо перевести страницу в режим "страничный" (когда синими полосами выделены границы страниц) и тогда меню появляется.
Я ума не приложу, в связи с чем связано такое поведение макроса, но именно так заработало.

А если открыть редактор кода, и вручную запустить макрос CreateItemsInCellContextMenu?
(или запустить из Excel через меню «макросы», которое появляется по нажатию Alf + F8)

В этом случае, контекстное меню появляется?

Хотя даже если путь к папке Program Files неверный, то контекстное меню ведь все равно должно появляться? Оно ведь не зависит от пути к Program Files.

Совершенно ничего не происходит. Как будто макроса нет.
Путь к папке Program Files завтра проверю, может и в этом дело.

Вряд ли могу подсказать... по вашим данным, Office и Windows на компах одинаковые,
соответственно, все также одинаково должно работать.
Может, на втором компе Windows 64-битная, и путь к папке Program Files выдается неверный?

Что значит «никаких признаков жизни»? Даже дополнительные пункты в контекстном меню не появляются?
Или только поиск не работает?

Добрый вечер.
Отличный макрос.
Но на одном ПК работает, а на другом нет (совсем никаких признаков жизни, даже ошибку не выдает).
Разрешение на макросы максимальные. Офис и там и там 2010. Винда и там и там 7.
Не подскажите, в чем возможная причина?

Спасибо.
Идея с формированием меню при нажатии ПКМ - супер!
Переделал под свою задачу, все работает отлично!

Отличный макрос! Очень помогает при поиске данных в определенной базе из Excel.
Заменил адрес поисковой ссылки и все... Работает!
Спасибо разработчикам!

«Подсвечивать результат» – это сделать так, чтобы пользователь в большом Вордовском документе легко увидел найденное вхождение. Например желтой заливкой выделить.

Здравствуйте, Александр.
Конечно можно - макросами что угодно можно сделать.
Только половину кода надо переделывать
И что значит - «подсвечивать результат»?

А можно искать подобным образом в Вордовском файле и подсвечивать результат?

на двух компьютерах excel 2007 копирую код из module1 и из ЭтаКнига в Personal.xlsb ,-безрезультатно.а если скопировать в другую книгу,то в ней все работает

Сейчас ещё раз посмотрел код - а изменений-то вроде и не нужно.
Просто скопируйте ВЕСЬ код из файла (в этом числе из модуля ЭтаКнига) в Personal.xls - и функционал будет доступен из любого файла Excel

я про небольшие изменения в код и спрашиваю

Надо весь код перенести в личную книгу макросов (Personal.xla) - тогда макрос будет работать во всех файлах.
Правда, потребуется внести небольшие изменения в код.

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

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
 __   __                         _        
\ \ / / _ __ __ _ _ __ (_) __ __
\ V / | '_ \ / _` | | '__| | | \ \/ /
| | | |_) | | (_| | | | | | > <
|_| | .__/ \__, | |_| |_| /_/\_\
|_| |___/
Введите код, изображенный в стиле ASCII-арт.

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

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