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

Скрытие отмеченных строк (с использованием элементов управления Checkbox, или без них)

В прикреплённом файле - 3 варианта реализации:

Получение списка подпапок из заданной папки по маске

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

Если надо получить список папок, имена которых удовлетворяют определённому критерию, используйте маску поиска (параметр Mask$)

Код функции и пример использования:

Sub ПоискПодходящихПодпапок()
    ' считываем в колекцию coll подходящие полные пути папок
    ' (поиск папок с названием, начинающимся на 09)
    Set coll = SubFoldersCollection("d:\", "09*")
 
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к папкам
        Debug.Print coll(i) ' выводим очередной путь в окно Immediate
    Next
End Sub

Программно задать ширину столбца Excel в пикселах (Width, ColumnWidth)

Как программно (макросом) задать ширину столбца в пикселах

Вроде бы - элементарное действие... но нет, здесь Microsoft нам усложнил задачу.

Получить ширину столбца в пикселах - не проблема, для этого есть свойство Width:

MsgBox "Ширина столбца с активной ячейкой: " & ActiveCell.Width

Но, увы, это свойство доступно только для чтения, - а для назначения ширины столбца нам придётся изменять значение другого свойства - ColumnWidth, которое задаётся отнюдь не в пикселах, а в символах (количестве знаков, которые поместятся в ячейке)

Результат - мы не можем со 100% точностью задать ширину столбца, чтобы она была равна заданному количеству пикселей.

Стал искать решение проблемы на сайте Microsoft - и увидел чудный макрос, который сначала ставит приблизительную ширину, и потом В ЦИКЛЕ подгоняет (увеличивает или уменьшает) значение ширины, до тех пор, пока результат не приблизитс к ожидаемому.

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

К тому же, подбор ширины столбца в цикле - очень медленный способ.

И вот что получилось:

Функция VBA для транспонирования массива.

Как известно, встроенная в Excel функция листа Transpose имеет ограничения, вследствии чего её не удаётся применять для транспонирования произвольных массивов.

Вот список ограничений встроенной функции Transpose:

Массив не может содержать элементов, длина которых превышает 255 знаков.
Массив не может содержать пустые (Null) значения.
Количество элементов не может превышать 5461.

Чтобы избежать этих ограничений, рекомендую использовать пользовательскую функцию TransposeArray:

Sub ПримерИспользования()
    ИсходныйМассив = ActiveSheet.UsedRange.Offset(1).Value
    ТранспонированныйМассив = TransposeArray(ИсходныйМассив)
End Sub

Макрос создания копии файла Excel в виде архива ZIP

Макрос для архивации текущей (или активной) книги Excel средствами Windows

(без использования сторонних программ-архиваторов)

Во вложении - файл, при запуске которого автоматически срабатывает такой макрос
При открытии этого файла, если включены макросы, в папке My Program Backups будет сохранена копия книги в формате ZIP (архив)
Папка, если таковая не существует, будет автоматически создана макросом.

Sub CreateBackup()
    ' Макрос создания резервной копии текущего файла
    ' Чтобы макрос обрабатывал активную книгу - замените в коде
    ' все ThisWorkbook на ActiveWorkbook
    ' Архивация файла осуществляется средствами Windows
    
    Const PROJECT_NAME = "My Program" ' название вашей программы (любой текст)
    On Error Resume Next: ThisWorkbook.Save ' сохраняем книгу Excel
    
    ' формируем путь к папке, куда будет помощена копия файла (в виде архива)
    BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups\")
    MkDir BackupsPath ' создаём папку, если таковой ещё нет
    
    ext$ = Split(ThisWorkbook.Name, ".")(UBound(Split(ThisWorkbook.Name, "."))) ' расширение файла
    ' формируем путь для копии файла Excel
    FileNameXls = BackupsPath & PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & "." & ext$
    ' формируем путь для создаваемого архива ZIP
    FileNameZip = BackupsPath & PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".zip"
 
    ThisWorkbook.SaveCopyAs FileNameXls ' создаём копию книги
    ZIPresult = Zip_File(FileNameXls, FileNameZip, True) ' упаковываем копию книги в архив ZIP
    
    Debug.Print "Результат архивации: " & IIf(ZIPresult, "выполнена успешно", "ошибка")
    Debug.Print "Создан архив: " & Dir(FileNameZip)
End Sub

Подсчёт количества файлов и подпапок в заданной папке средствами VBA

Этот макрос выводит информацию о папке - например, её размер, и количество файлов в ней:

Sub ПодсчётКоличестваФайловВПапке()
    ' задаём папку
    FolderPath = "C:\Documents and Settings\Admin\Рабочий стол\"
 
    ' получаем характеристики папки
    Set FSO = CreateObject("Scripting.FileSystemObject")
    КоличествоФайловВПапкеБезУчётаПодпапок = FSO.GetFolder(FolderPath).Files.Count
    КоличествоПодпапок = FSO.GetFolder(FolderPath).SubFolders.Count
    РазмерПапкиВБайтах = FSO.GetFolder(FolderPath).Size
 
    ' подсчитываем количество файлов с учётом файлов в подпапках
    КоличествоФайловВПапкеСУчётомПодпапок = FilesCount(FolderPath)
 
    Debug.Print "В папке найдено " & КоличествоФайловВПапкеБезУчётаПодпапок & " файлов и " & _
                КоличествоПодпапок & " подпапок. Всего файлов: " & КоличествоФайловВПапкеСУчётомПодпапок
    Debug.Print "Папка занимает на диске " & РазмерПапкиВБайтах & " байтов (" & _
                FileOrFolderSize(РазмерПапкиВБайтах) & ")"
End Sub

Результат работы кода (в окне Immediate):

В папке найдено 186 файлов и 31 подпапок. Всего файлов: 4216
Папка занимает на диске 193158100 байтов (184 Мб)

Если же вам надо вывести список файлов на лист Excel - смотрите функцию FilenamesCollection:
http://excelvba.ru/code/FilenamesCollection

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

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

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

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

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

Надстройка для загрузки списка файлов на лист Excel

Скриншот формы поиска файлов в заданной папке

Надстройка, позволяющая загрузить из выбранной папки список файлов на лист Excel.

Автор: VictorM

Особенности надстройки:

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

Удаление "пустых строк" из массива

Удаление "пустых строк" из диапазона ячеек при помощи макроса

Function DeleteBlankRows(ByVal arr As Variant, ByVal col As Long) As Variant

Sub ПримерИспользования()
    On Error Resume Next
    arr = [a1:d15] ' считываем значения ячеек диапазона [a1:d15] в массив arr
    
    ' получаем массив arr2, в 5-м столбце которого нет пустых значений
    arr2 = DeleteBlankRows(arr, 5)
 
    [f1:z111].Clear ' очищаем диапазон ячеек [f1:z111] на листе
    
    ' вставляем массив без пустых строк обратно на лист
    [f1].Resize(UBound(arr2, 1), UBound(arr2, 2)).Value = arr2
End Sub

Автоподбор высоты объединённых ячеек

Предлагаю 2 варианта автоподбора высоты объединённых ячеек в Excel
(оба работаю не идеально, - но, тем не менее, в большинстве случаев и этого будет достаточно)

1 вариант: (разъединение, автоподбор, объединение)

Sub AutoFitMergeAreaSize(ByRef cell As Range)
    Dim ra As Range: Set ra = cell.MergeArea
    cell.UnMerge
    cell.EntireRow.AutoFit
    ra.Merge
End Sub
 
Sub ПримерИспользования_АвтоподборВысотыОбъединённойЯчейки()
    AutoFitMergeAreaSize ActiveCell
    AutoFitMergeAreaSize [d3]
End Sub

2 вариант:(то же самое, по сути, только кода побольше)

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

НАДСТРОЙКИ ДЛЯ EXCEL