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

Макросы VBA Excel

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

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

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

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

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

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

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: В коде использована функция сортировки двумерного массива, и функция множественного выбора файлов.

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

Представим, что нам поставлена задача покрасить каждую 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, - это если надо изменить высоту множества строк на листе, причем строки, раполагающиеся на равном расстоянии друг от друга, должны иметь одинаковую высоту.

Звонок из Excel через SIP софтфон Sippoint

При работе с базами данных в Excel, где в ячейках присутствуют номера телефонов, порой требуется выполнять звонки по множеству номеров, указанных в таблице.

Обычно этот процесс не автоматизирован - пользователь, глядя в таблицу Excel, набирает на своём мобильном телефоне номер из очередной ячейки.

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

Предлагаю вашему вниманию макрос, который позволит нажатием одной кнопки набрать номер телефона из ячейки в популярном софтфоне Sippoint (от компании SIPNET)

Sub ПозвонитьНаНомерИзВыделеннойЯчейкиExcel()
    ' макрос наберёт номер из активной ячейки в программе Sippoint
    CallWithSIPPOINT Trim(ActiveCell)
End Sub

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