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

Поиск адресов электронной почты (email) на листе Excel

Данный макрос предназначен для поиска адресов электронной почты на листе Excel, с последующим выводом найденных адресов на отдельный лист.

Создание папок с подпапками макросом VBA

Как известно, VBA-функция MkDir может создать только папку в существующем каталоге (папке).

Например, код MkDir "C:\Папка\" отработает корректно в любом случае (создаст указанную папку),
а код MkDir "C:\Папка\Подпапка\Каталог\" выдаст ошибку Run-time error '76': Path not found
(потому что невозможно создать каталог Подпапка в несуществующем ещё каталоге Папка)

Можно, конечно, использовать несколько функций MkDir подряд - но это усложняет код.

Самый простой способ решения проблемы - использование WinAPI-функции SHCreateDirectoryEx, которая может создать все нужные папки и подпапки за один запуск.

Сбор данных из множества текстовых файлов с разделителями

К примеру, есть у вас несколько десятков (или сотен) текстовых файлов с подобным содержимым:
(количество файлов, и количество строк данных в каждом файле не ограничено)

1c04;1J0-698-151-G;1 комплект тормозных накладок;1J0698151G;1J0698151G;5;1
1c04;1H0698151A;Тормозные колодки;1H0698151A;1H0698151A;1;1
1c04;1K0-698-151-B;Тормозные колодки;1K0698151B;1K0698151B;2;1

А надо из всего этого сформировать табличку в Excel - приблизительно такого вида:

Пример таблицы в Excel

На помощь придёт функция DATfolder2Array

Sub ПримерИспользованияФункции_DATfolder2Array()
    Папка = "D:\Проекты\DATs\"    ' папка, в которой будет производиться поиск файлов DAT для обработки
    Dim ErrorsArray    ' пустой массив для ошибок

    ' считываем данные из все файлов .DAT в папке в двумерный массив
    DataArr = DATfolder2Array(Папка, 7, "1,2,4,5", ErrorsArray)
 
    ' результаты выводим на листы "errors" и "result" (они должны существовать)
    Array2worksheet Worksheets("errors"), ErrorsArray, _
                    Array("Имя файла", "Номер строки", "Данные из строки")
    Array2worksheet Worksheets("result"), DataArr, _
                    Array("Ячейка", "Штрих-Код", "Наименование", "код 1С", "код произв.", "кол-во", "счетовод")
End Sub

Прикрепление и извлечение различных файлов из книги Excel

Скриншот программы, позволяющей прикреплять файлы к книге Excel

Можно ли прикрепить (вложить) произвольные файлы в обычную книгу Excel?
А потом извлечь эти файлы в заданную папку, и работать с ними?

Казалось бы, Excel такого не позволяет. (а если и позволяет, то извлечь вложенные файлы без из запуска - весьма проблематично)
Но, при помощи макросов, можно реализовать что угодно (и сохранение\извлечение файлов в том числе)

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

В прикреплённом к статье файле находятся 2 модуля класса (AttachedFiles и AttachedFile), а также примеры их использования в виде макросов, позволяющих управлять вложениями в книге Excel.

Пример использования функционала модулей класса для сохранения в книге Excel исполняемого файла, с последующим извлечением:

Sub ПрикрепитьФайл()    ' прикрепляем файл к книге Excel
    Dim FileManager As New AttachedFiles, res As Boolean
    res = FileManager.AttachNewFile("C:\WINDOWS\notepad.exe")
End Sub

Sub ИзвлечьФайл()    ' из книги Excel на диск
    Dim FileManager As New AttachedFiles, res As Boolean
    On Error Resume Next ' на случай, если среди вложений нет файла notepad.exe
    res = FileManager.GetAttachment("notepad.exe").SaveAs("C:\MyProgram.exe")
End Sub

Sub ЗапуститьВложенныйФайл()    ' из книги Excel на диск
    Dim FileManager As New AttachedFiles
    On Error Resume Next ' на случай, если среди вложений нет файла notepad.exe
    FileManager.GetAttachment("notepad.exe").Run
End Sub

Сортировка двумерного массива на VB (VBA)

Сортировка двумерного массива по нулевому столбцу

Public Function CoolSort(SourceArr As Variant) As Variant
    ' сортировка двумерного массива по нулевому столбцу
    Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Do Until Check
        Check = True
        For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
            If Val(SourceArr(iCount, 0)) > Val(SourceArr(iCount + 1, 0)) Then
                For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)