Главная » Макросы VBA Excel

Макросы VBA Excel — Страница 20

Вставка картинки в центр диапазона ячеек

Макрос вставляет изображение из файла PicturePath$
в центр диапазона ячеек ra, соблюдая пропорции картинки

Код надо разместить в модуле листа
(или заменить Me на Worksheets("ИмяЛиста")

Преобразование списка номеров и названий столбцов в массив значений

Функция ParseColumnsStringEx предназначена для преобразования введенного пользователем списка столбцов в одномерный массив числовых значений.

Назначение функции: исключить ошибки пользовательского ввода, преобразовать буквенные названия столбцов в числовые значения.

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

Private Sub ПримерИспользования_ParseColumnsStringEx()
    Dim txt$, txt1$, txt2$
    ' исходная строка с номерами столбцов (c ошибками ввода)
    txt$ = "4-4 , -a- C;8,Я-7,-11-9-F, Е --К; 4,21-,6-F"
 
    ' получаем массив столбцов
    arr = ParseColumnsStringEx(txt)
 
    ' выводим список столбцов:  4,1,2,3,8,7,11,10,9,8,7,6,5,6,7,8,9,10,11,4,21,6,
    For i = LBound(arr) To UBound(arr): Debug.Print arr(i) & ",";: Next i: Debug.Print
 
    ' ======================================
    ' или, например, такая строка
    txt$ = "4-5,8 -k, 6-5;a,e,3,4, 46-BA"
 
    ' получаем массив столбцов (c «промежуточными» значениями)
    arr2 = ParseColumnsStringEx(txt, txt1, txt2)
 
    Debug.Print txt1    ' выводит  4-5;8-K;6-5;A;E;3;4;46-BA
    Debug.Print txt2    ' выводит  4-5,8-11,6-5,1,5,3,4,46-53
    columnsList$ = Join(arr2, ",")
    Debug.Print columnsList$    ' выводит 4,5,8,9,10,11,6,5,1,5,3,4,46,47,48,49,50,51,52,53
End Sub

Функции VBA для перевода пикселей в твипы

Функции для перевода пикселей в твипы, и обратно

Function TwipsPerPixel(Optional ByVal Dimension As Long = LOGPIXELSY) As Long
    Const TwipsPerInch As Long = 1440: Dim DesktopDC As Long
    DesktopDC = GetDC(HWND_DESKTOP)
    TwipsPerPixel = TwipsPerInch / GetDeviceCaps(DesktopDC, Dimension)
    Call ReleaseDC(HWND_DESKTOP, DesktopDC)
End Function
Public Function TwipToPixel(ByVal Twips As Long) As Long    'перевод твипов в пиксели
    TwipToPixel = Twips / TwipsPerPixel()
End Function
Public Function PixelToTwip(ByVal Pixels As Long) As Long    'перевод пикселей в твипы

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

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

Функция для добавления GET-параметра в ссылку (URL)

Если требуется добавить в URL новый GET-параметр, или заменить значение имеющегося, - можно воспользоваться этой функцией.

Sub ПримерИспользования()
    URL$ = "http://market.yandex.ru/model.xml?modelid=968028&np=0"
 
    URL$ = URL_SetParameter(URL$, "how", "aprice") ' такого параметра нет - он добавляется
    URL$ = URL_SetParameter(URL$, "np", "1") ' такой параметр есть - он заменяется
    
    Debug.Print URL$
    ' на выходе получаем ссылку
    ' <a href="http://market.yandex.ru/model.xml?modelid=968028&hid=512743&how=aprice&np=1
End" title="http://market.yandex.ru/model.xml?modelid=968028&hid=512743&how=aprice&np=1
End">http://market.yandex.ru/model.xml?modelid=968028&hid=512743&how=aprice&n...</a> Sub

Код функции:

Сохранение двумерного массива в файл

Функция предназначена для сохранения двумерного массива в файл формата XLS

Sub SaveArray(ByVal Arr, ByVal ColumnNames, ByVal DocName$)
    ' Получает двумерный массив Arr с данными, и массив заголовков столбцов ColumnNames.
    ' Создаёт новый файл в подпапке СФОРМИРОВАННЫЕ ДОКУМЕНТЫ с именем DocName$
    On Error Resume Next
 
    ' создаём подпапку (там же, где текущий файл Excel)
    folder$ = ThisWorkbook.Path & "\СФОРМИРОВАННЫЕ ДОКУМЕНТЫ\": MkDir folder$
 
    Application.ScreenUpdating = False
    Dim sh As Worksheet, wb As Workbook

Преобразование 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

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

Вывод информации о надстройках, установленных в Excel

Макрос ShowAddinsList выводит список надстроек, подключенных в Microsoft Excel:

Sub ShowAddinsList()
    Dim count As Integer, item As AddIn, msg As String, txt1$, txt2$
    For Each item In Application.AddIns
        If item.Installed Then
            txt1$ = txt1$ & vbTab & item.Name & vbNewLine
            count = count + 1
        Else
            txt2$ = txt2$ & vbTab & item.Name & vbNewLine
        End If
    Next item
    msg = "Всего надстроек: " & AddIns.count & vbNewLine & vbNewLine
    msg = msg & "Из них установлено (подключено) - " & count & ":" & vbNewLine & txt1$ & vbNewLine
    msg = msg & "Не подключено надстроек - " & AddIns.count - count & ":" & vbNewLine & txt2$
 
    MsgBox msg, vbInformation, "Информация о подключенных надстройках Excel"
End Sub

Скриншот выводимого сообщения:

Макрос открытия гиперссылок в браузере

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

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

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

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