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

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

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

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

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

Макросы VBA, использующие .NET Framework

В данной статье приведены макросы, работающие только при установленном .NET Framework

Перестановка строк в обратном порядке в текстовом файле:

Sub ReverseTextFile()
 
    Filename$ = "c:\test.txt" ' строки в этом файле будут переставлены в обратном порядке

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = FSO.OpenTextFile(Filename$, 1)
 
    Set a = CreateObject("System.Collections.Stack") ' создаем объект класса «стек»

    Do Until objFile.AtEndOfStream
        a.push objFile.ReadLine ' добавляем строку в стек
    Loop

Функции 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    'перевод пикселей в твипы

Макрос для создания списка случайных адресов email

Макрос выводит на активный лист (в первый столбец) случайные email

Я использовал этот макрос для тестирования программы рассылки писем.

Sub GenerateEmails()
    On Error Resume Next: Err.Clear
    Dim ra As Range: Set ra = Range([A2], Range("A" & Rows.Count).End(IIf(Len(Range("A" & Rows.Count)), xlDown, xlUp)))
    Dim cell As Range
    txt = "abcdefghijklmnopqrstuvwxyz_1234567890"
    For Each cell In ra.Cells
        n = n + 1: dom$ = Choose(n Mod 3 + 1, "@mail.ru", "@yandex.ru", "@gmail.com")
        Randomize: Nam$ = ""
        For i = 1 To Rnd(n) * 5 + 4
            Nam$ = Nam$ & Mid(txt, Fix(Rnd(i) * Len(txt) + 1), 1)
        Next
        cell = Nam$ & dom$
    Next cell
End Sub

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

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

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

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