Разное

Разное - всего понемногу

В этой статье опубликованы различные вспомогательные функции на VBA, которые порой помогают в работе.

Восстановление форматирование гиперссылок

Если вы выделили ячейки с гиперссылками, и случайно изменили их форматирование (цвет шрифта и т.п.),
а теперь хотите вернуть все гиперссылки в книге к исходному виду (синие и подчеркнутые), — то вам поможет этот макрос.

ВНИМАНИЕ: макрос применяется ко всем листам, и всем ячейкам, содержащим гиперссылки.

Sub RestoreHyperlinksStyle()
    Dim cell As Range, sh As Worksheet
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        For Each cell In sh.UsedRange.SpecialCells(xlCellTypeConstants)

Работа с HTML: поиск тегов (RegExp) и преобразование HTML в текст

В данной статье приведён код 2 функций, которые позволят вам найти на веб-странице нужные HTML теги,
и преобразовать HTML в текст

Особенность этого кода, - использование регулярных выражений (Regexp) для поиска в HTML

Эти функции лежат в основе моей надстройки «Парсер сайтов»

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

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' ищем div id="mod-lists", и берем его начинку (innerHTML)
' Индекс 1 после innerHTML означает, что если будет найдено несколько таких тегов, - макрос возьмет только первый
res = GetTags(txt, "div", "id", "mod-lists", "innerHTML 1")
 
 
' ищем ВСЕ теги span класса product (функция вернёт массив значений в переменную arr)
arr = Split(GetTags(txt, "span", "class", "product", "outerHTML"), ARSEP)
 
 
' ищем гиперссылку (тег a класса blue-link), и возвращаем атрибут href
link$ = GetTags(txt, "a", "class", "blue-link", "href")
 
 
' ищем ЛЮБОЙ ТЕГ класса price, и берем последний найденный (last), преобразовав его в текст (ConvertToText)
price = GetTags(txt, "any tag", "class", "price", "ConvertToText last")

Есть возможность удалять теги из HTML (параметр DeleteTags), а также использовать подстановочный символ * до или после значения атрибута.
Можно также выполнять поиск по маске для атрибутов:

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' удаляем все div, где имя класса начинается с old
txt = GetTags(txt, "div", "class", "old*", "DeleteTags")
 
 
' ищем ВСЕ гиперссылки по маске /item/
links_array = Split(GetTags(txt, "a", "AttributesPattern", "*/item/*", "href"), ARSEP)

Функцией преобразования HTML в текст (ConvertHTMLtoText) можно воспользоваться отдельно (без функции GetTags)

Весь приведённый ниже код, скопируйте в отдельный стандартный модуль

Поиск данных по оператору сотовой связи по номеру телефона

mobile_phones.jpg

При вводе в первый столбец номера телефона,
макрос выполняет веб-запрос на сайт spravportal.ru
и выводит в соседние столбцы страну, регион, оператора сотовой связи, и ссылку на сайт оператора.

Если в первый столбец вставлены сразу несколько номеров, - макрос выполнит запросы для всех этих номеров по-очереди
(ВНИМАНИЕ! выполнение запроса занимает время, около 1-2 секунд. не вставляйте сразу много номеров, а то Excel надолго подвиснет, подгружая данные)

В макросе использованы функции:
Поиск текста на листе: http://excelvba.ru/code/FindAndInsert

Преобразование URL национального домена в punycode

При использовании компонента WinHTTPrequest для выполнения запроса к сайту,
требуется предварительно преобразовать URL национальных доменов с использованием метода Punycode.

PS: если вы загружаете исходный код вебстраницы с использованием WinAPI функции URLDownloadToFile, - подобное преобразование не обязательно

Sub ПримерИспользования_ConvertURLtoPunycode()
    Dim host$, newURL$
 
    ' исходная ссылка
    host$ = "http://государство.президент.рф/советы"
 
    ' результат преобразования: "http://xn--80aebe3cdmfdkg.xn--d1abbgf6aiiy.xn--p1ai/%D1%81%D0%BE%D0%B2%D0%B5%D1%82%D1%8B"
    newURL$ = ConvertURLtoPunycode(host$)
    MsgBox newURL$
End Sub

Автор функции преобразования: Achim Neubauer
Источник: www.herber.de/forum/archiv/1192to1196/1192164_Punycode_Unicode.html

Для использования функции, добавьте в проект стандартный модуль, и в него вставьте следующий код:

Авторизация на Яндексе с использованием WinHttpRequest

Приведённый ниже код выполняет авторизацию на Яндексе, отправляя GET и POST запрос

На время POST запроса отключается автоматический редирект, чтобы сохранить Cookies, переданные в ответе сервера

PS: Код предназначен для специалистов!
Я не готов отвечать на вопросы, почему у вас не получилось авторизоваться, и что делать с этим макросом дальше (как получать данные)

Эта функция нашла применение в универсальной программе для сбора данных с Яндекс.Маркет

Запуск макроса VBA по таймеру

В Excel есть инструментарий для запуска макроса по расписанию, - Application.Ontime
При помощи этого метода можно запускать макрос с заданным интервалом (например, раз в секунду)

Но есть и другой вариант, - использование объекта htmlfile:
(код надо поместить в модуль ЭтаКнига - ThisWorkbook)

Private m_TimerId As Variant
Private m_doc As Object
Const ATTRNAME = "VBATimerHandler"
 
Private Sub StartTimer()
    Const Script = "document.documentElement.getAttribute('" & ATTRNAME & "').TimerProc()"
    EndTimer
    Set m_doc = CreateObject("htmlfile")

Авторизация на сайте atsenergo.ru

Данный макрос выполняет 2 HTTP запроса (GET и POST) для авторизации на сайте atsenergo.ru
В случае успешной авторизации, функция возвращает идентификатор сессии,
который используется в дальнейших запросах для скачивания файлов.

Макрос представляется сайту браузером Google Chrome
Чтобы код сработал, надо задать правильные логин-пароль

Макрос опубликован в качестве примера использования объекта WinHttpRequest для работы с сайтами.

Декодирование JSON (преобразование кодов символов в буквы)

Функция предназначена для перевода ответа веб-сервера в формате JSON в читаемый текст.

Пример использования функции JSON_decode:

Sub test_JSON_decode()
    ' исходная строка в кодировке JSON
    txt$ = "<th class=\""label\"">\u0428\u0442\u0440\u0438\u0445\u043a\u043e\u0434<\/th>\n    <td class=\""data\"">408<\/td>\n"
 
    Debug.Print JSON_decode(txt)
    ' на выходе получаем: <th class="label">Штрихкод</th>    <td class="data">408</td>
End Sub

Код функции JSON_decode:

Макрос округления массива (значений в заданном столбце)

Макрос предназначен для округления значений в заданном столбце массива, с заданной точностью и направлением округления

Sub Пример_Округления_Массива()
    Dim arr As Variant
 
    ' считываем данные из диапазона ячеек в массив
    arr = Range("a2:c20").value
 
    ' переводим весь второй столбец в числа (на всякий случай)
    For i = LBound(arr) To UBound(arr)
        arr(i, 2) = Val(Replace(arr(i, 2), ",", "."))
    Next i
 
    ' значения во втором столбце массива округляем до нуля знаков после запятой в бОльшую сторону
    RoundArray arr, 2, 0, 1
 
    ' выводим результат на 4 столбца правее
    Range("a2:c20").offset(, 4).value = arr
End Sub

Код функции округления: