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

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

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

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

Сортировка двумерного массива на 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)

Поиск в Google значений из ячеек листа Excel

Макрос для поиска текста выделенных ячеек в Google

Макрос предназначен для поиска текста из выделенных ячеек в поисковой системе Google.

Функция поиска доступна из контекстного меню ячеек:

добавление пункта поиска в контекстное меню ячеек Excel

Как вы можете видеть на скриншоте, есть возможность выбора браузера.
На выбор представлены наиболее популярные браузеры: Internet Explorer, Mozilla Firefox, Opera, и Google Chrome.

Макросы для получения размера изображения, и создания уменьшенной копии картинки

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

 

Эти макросы нашли применение в универсальной надстройке для вставки картинок в Excel

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

Если вы не можете разобраться, как применить эти макросы для своих задач, — просто воспользуйтесь готовой надстройкой.
(там уже все сделано — достаточно нажать одну кнопку для вставки уменьшенных (сжатых) изображений)

Функции для работы с текстовыми файлами

Данные функции предназначены для работы с текстовыми файлами из VBA Excel.

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

Чтение текстового файла в переменную:

Function ReadTXTfile(ByVal filename As String) As String
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.OpenTextFile(filename, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
    Set ts = Nothing: Set fso = Nothing
End Function
Запись в текстовый файл из переменной:
Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
    On Error Resume Next: Err.Clear
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write txt: ts.Close
    SaveTXTfile = Err = 0
    Set ts = Nothing: Set fso = Nothing
End Function
Добавление в текстовый файл из переменной:
Function AddIntoTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
    On Error Resume Next: Err.Clear
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.OpenTextFile(filename, 8, True): ts.Write txt: ts.Close
    Set ts = Nothing: Set fso = Nothing
    AddIntoTXTfile = Err = 0
End Function