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

Визуализация работы макроса при помощи прогресс-бара

Прогресс-бар на VBA

Данный прогресс-бар позволяет отображать ход выполнения любого макроса.

Для использования этого индикатора перетащите из файла-примера в свой файл модуль класса ProgressIndicator и форму F_Progress

Использовать прогресс бар сравнительно просто - достаточно добавить в макрос несколько строк кода:

Макрос (функция) для получения курса валют с сайта ЦБ РФ

Данный код (пользовательская функция) позволяет получить данные о курсе валюты с сайта Центробанка.

Данную функцию можно использовать и в виде формулы на листе Excel (см. пример во вложении)

Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Double
...

Sub ПримерИспользованияФункции_GetRate()
    MsgBox "Сегодня курс доллара к рублю составил " & GetRate("USD", Now), vbInformation
    MsgBox "А вчера курс евро к рублю был равен " & GetRate("EUR", Now - 1), vbInformation
End Sub

Поддерживается получение курсов рубля по отношению к наиболее распространённым валютам мира.

Если вы желаете вывести информацию по всем валютам - используйте макрос ВывестиСегодняшниеКурсыВсехВалют

Вывод диалоговых окон выбора файла и папки средствами VBA (выбрать файл или папку)

Функции GetFileName и GetFilePath по сути аналогичны, и предназначены для вывода диалогового окна выбора файла
(при этом можно указать стартовую папку для поиска файла, и тип/расширение выбираемого файла)

Функция GetFilenamesCollection позволяет выборать сразу несколько файлов в одной папке.

Функция GetFolderPath работает также, только служит для вывода диалогового окна выбора папки.

Макрос для исправления повреждённых гиперссылок во всей книге Excel

Макрос для исправление повреждённых гиперссылок во всей книге:

Sub ЗаменаИспорченныхГиперссылок()
    On Error Resume Next
    Dim hl As Hyperlink, oldString As String, newString As String, sh As Worksheet
    ' часть гиперссылки, подлежащая замене
    oldString = "C:\Documents and settings\Бухгалтер\Application data"
    ' на что заменяем
    newString = "\\адрес_сервера"
    For Each sh In ActiveWorkbook.Worksheets    ' перебираем все листы в активной книге
        For Each hl In sh.Hyperlinks    ' перебираем все гиперссылки на листе
            If hl.Address Like oldString & "*" Then
                hl.Address = Replace(hl.Address, oldString, newString)
            End If
        Next
    Next sh
End Sub
Макрос может быть полезен для замены абсолютных гиперссылок на относительные, а также помогает вернуть работоспособность ссылок после случайного сохранения файла Excel в другой папке (на другом диске).

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

Sub ЗаменаИспорченныхГиперссылок2()
    On Error Resume Next
    Dim hl As Hyperlink, oldString$, newString$, sh As Worksheet, n&, msg$, coll As New Collection, Item
 
    ' часть гиперссылки, подлежащая замене
    oldString = "../../AppData/Roaming/Microsoft/Excel/"
    ' на что заменяем
    newString = "C:\Users\Admin\Desktop\ОТЧЁТЫ ВСЕ\"
 
    For Each sh In ActiveWorkbook.Worksheets    ' перебираем все листы в активной книге
        For Each hl In sh.Hyperlinks    ' перебираем все гиперссылки на листе
            ' Debug.Print hl.Address
            If (hl.Address Like oldString & "*") Or (hl.Address Like Replace(oldString, "/", "\") & "*") Then
                hl.Address = Replace(hl.Address, oldString, newString, , , vbTextCompare)
                hl.Address = Replace(hl.Address, Replace(oldString, "/", "\"), newString, , , vbTextCompare)
                n = n + 1
            Else
                If InStr(1, hl.Address, "mailto", vbTextCompare) = 0 Then coll.Add hl.Address, UCase(hl.Address)
            End If
        Next
    Next sh
 
    For Each Item In coll
        msg$ = msg$ & Item & vbNewLine
    Next
 
    MsgBox "Заменено гиперссылок: " & n & IIf(Len(msg$), vbNewLine & vbNewLine & _
                                                         "Также в файле найдены ссылки на:" & vbNewLine & msg$, ""), vbInformation
End Sub

Скачать файл из интернета без использования WinAPI

Часто требуется макросом скачать некий файл из интернета.