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

Функция получения повторяющегося диапазона ячеек

Представим, что нам поставлена задача покрасить каждую 10-ю строку таблицы в серый цвет, начиная с пятой строки (таблица занимает 60 строк)

Проще всего (да и быстрее) это сделать при помощи функции RepeatRange:

Sub Пример1()
    RepeatRange(Rows(5), 6, 10, xlDown).Interior.ColorIndex = 15
End Sub

Или другая подобная задача: получить ссылку на диапазон, состоящий из 4 блоков размером 8*3, располагающихся горизонтально со смещением 5 столбцов, и потом нарисовать рамки вокруг этих ячеек.
Тут также поможет функция RepeatRange:

Sub Пример2()
    RepeatRange([a2:c9], 4, 5, xlToRight).Borders.LineStyle = xlContinuous
End Sub

Пример - в прикреплённом к статье файле.

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

Вывод отсортированного списка файлов

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

Sub ВыводОтсортированногоСпискаФайлов()
    On Error Resume Next
    Dim СписокФайлов As FileDialogSelectedItems
    СтартоваяПапка = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    ' выводим окно выбора
    Set СписокФайлов = GetFilenamesCollection("Выберите файлы на рабочем столе", СтартоваяПапка)
 
    If СписокФайлов Is Nothing Then Exit Sub  ' выход, если пользователь отказался от выбора файлов
    ReDim arr(0 To СписокФайлов.Count - 1, 0 To 1)
    For Each File In СписокФайлов ' заполняем двумерный массив
        arr(i, 1) = File: arr(i, 0) = Fix(CDbl(FileDateTime(File))): i = i + 1
    Next
 
    CoolSort arr ' сортируем двумерный массив

    For i = LBound(arr) To UBound(arr)    ' выводим файлы в порядке даты создания
        Debug.Print "Дата: " & CDate(arr(i, 0)) & " - файл " & arr(i, 1)
    Next i
End Sub

Пример результата (из окна Immediate):

Дата: 27.10.2009 - файл C:\Documents and Settings\Admin\Рабочий стол\Apache LOGs parser.xls
Дата: 11.06.2010 - файл C:\Documents and Settings\Admin\Рабочий стол\123Книга1.xls
Дата: 24.09.2010 - файл C:\Documents and Settings\Admin\Рабочий стол\2010-09-24.xls
Дата: 12.11.2010 - файл C:\Documents and Settings\Admin\Рабочий стол\111.info
Дата: 28.12.2010 - файл C:\Documents and Settings\Admin\Рабочий стол\Armstrong.xls
Дата: 02.01.2011 - файл C:\Documents and Settings\Admin\Рабочий стол\buch.xls

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

Декодирование 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:

Установка и удаление ссылок (References) на другие проекты VBA

Sub RemoveReference()
    For Each Ref In Application.VBE.ActiveVBProject.References
        ' Debug.Print Ref.Name

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

Разное

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

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

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