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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Макрос создания копии файла 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

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

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

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

Автор: VictorM

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

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