Vba excel сохранить книгу с похожим именем
Доброго времени суток.Проконсультируйте,пожалуйста,как сделать макрос,который бы сохранял копию книги в определенной папке под именем вида Имя(I)[I-переменная;I=1,2. n]. Если такое имя уже существует,то сохраняет под именем Имя(max(I)+1),где max(I)-максимальная из переменных I,содержащихся в именах файлов,сохраненных в папке.
Заранее благодарен за любую помощь.
Доброго времени суток.Проконсультируйте,пожалуйста,как сделать макрос,который бы сохранял копию книги в определенной папке под именем вида Имя(I)[I-переменная;I=1,2. n]. Если такое имя уже существует,то сохраняет под именем Имя(max(I)+1),где max(I)-максимальная из переменных I,содержащихся в именах файлов,сохраненных в папке.
Заранее благодарен за любую помощь. VanDerGraat
А Вам нужна именно нумерация?
А сохранение под именем с добавкой суффикса из даты и времени не подойдёт? Если подойдёт, то посмотрите в топике Макрос Save_Copy_As .
Честно говоря, мне лень возиться с переделкой того макроса.
Попробуйте на его основе сами. А для получения имени с номером можете ввести туда вычисление имени такой функцией:[vba]
Private Function NextName(sPath$, sWdROOT$, sExp$) ' вычисление очередного уникального имени файла с корнем sWdROOT в папке sPath
NextName = False
On Error GoTo eXXit
GetAttr (sPath) ' если папка не существует, то будет ошибка и NextName=False
Dim i%
Do
NextName = sPath & sWdROOT & "(" & i & ")" & sExp
i = i + 1
Loop While Dir(NextName) <> "" ' пока имя не будет уникальным в папке
eXXit: End Function
А Вам нужна именно нумерация?
А сохранение под именем с добавкой суффикса из даты и времени не подойдёт? Если подойдёт, то посмотрите в топике Макрос Save_Copy_As .
Честно говоря, мне лень возиться с переделкой того макроса.
Попробуйте на его основе сами. А для получения имени с номером можете ввести туда вычисление имени такой функцией:[vba]
Private Function NextName(sPath$, sWdROOT$, sExp$) ' вычисление очередного уникального имени файла с корнем sWdROOT в папке sPath
NextName = False
On Error GoTo eXXit
GetAttr (sPath) ' если папка не существует, то будет ошибка и NextName=False
Dim i%
Do
NextName = sPath & sWdROOT & "(" & i & ")" & sExp
i = i + 1
Loop While Dir(NextName) <> "" ' пока имя не будет уникальным в папке
eXXit: End Function
С уважением,
Алексей
MS Excel 2003 - the best.
Private Function NextName(sPath$, sWdROOT$, sExp$) ' вычисление очередного уникального имени файла с корнем sWdROOT в папке sPath
NextName = False
On Error GoTo eXXit
GetAttr (sPath) ' если папка не существует, то будет ошибка и NextName=False
Dim i%
Do
NextName = sPath & sWdROOT & "(" & i & ")" & sExp
i = i + 1
Loop While Dir(NextName) <> "" ' пока имя не будет уникальным в папке
eXXit: End Function
Sub Save_Copy_As_I()
'---------------------------------------------------------------------------------------
' Procedure : Save_Copy_As_I
' Author : Alex_ST
' Topic_HEADER : Сохранить копию текущего файла, запомнив папку для сохранения
' Topic_URL : http://www.excelworld.ru/forum/2-1639-18265-16-1335949159
' DateTime : 02.05.12, 12:59
' Purpose : Сохранение копии активного файла с автоматическим увеличением суффикса (номера копии)
' Notes : Путь сохранения копий хранится в коллекции .Names книги (в именованном диапазоне)
'---------------------------------------------------------------------------------------
Const sPath_in_Names = "Path4SaveCopyAs" ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла
Dim sDirPath$, sExp$, sMainName$, FileName, i%
With ActiveWorkbook
On Error Resume Next
sDirPath = .Names(sPath_in_Names).Value ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names
If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Path & "\" ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным ActiveWorkbook.Path
sDirPath = Mid(sDirPath, 3, Len(sDirPath) - 3) ' убрать из считанного значения в начале "= и в конце "
sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\") ' на всякий случай (если имя было задано в ручную и при этом не верно - без слэша)
.Names(sPath_in_Names).Value = sDirPath ' запомнить путь сохранения копий в коллекции .Names под именем sPath_in_Names
sExp = Right(.Name, Len(.Name) - InStrRev(.Name, ".") + 1) ' расширение файла вместе с точкой (например, ".xls")
sMainName = Left(.Name, Len(.Name) - Len(sExp))
Do
FileName = sDirPath & sMainName & "(" & i & ")" & sExp: i = i + 1
Loop While Dir(FileName) <> "" ' пока имя не будет уникальным в папке
FileName = Application.GetSaveAsFilename(InitialFileName:=FileName, _
FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
Title:="Сохранение копии файла") 'задать путь сохранения и имя копии файла в окне выбора
If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем
sDirPath = Left(FileName, InStrRev(FileName, "\")) ' путь к папке сохранения копий без имени файла
.Names(sPath_in_Names).Value = sDirPath ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names
.SaveCopyAs FileName
End With
End Sub
Sub Save_Copy_As_I()
'---------------------------------------------------------------------------------------
' Procedure : Save_Copy_As_I
' Author : Alex_ST
' Topic_HEADER : Сохранить копию текущего файла, запомнив папку для сохранения
' Topic_URL : http://www.excelworld.ru/forum/2-1639-18265-16-1335949159
' DateTime : 02.05.12, 12:59
' Purpose : Сохранение копии активного файла с автоматическим увеличением суффикса (номера копии)
' Notes : Путь сохранения копий хранится в коллекции .Names книги (в именованном диапазоне)
'---------------------------------------------------------------------------------------
Const sPath_in_Names = "Path4SaveCopyAs" ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла
Dim sDirPath$, sExp$, sMainName$, FileName, i%
With ActiveWorkbook
On Error Resume Next
sDirPath = .Names(sPath_in_Names).Value ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names
If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Path & "\" ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным ActiveWorkbook.Path
sDirPath = Mid(sDirPath, 3, Len(sDirPath) - 3) ' убрать из считанного значения в начале "= и в конце "
sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\") ' на всякий случай (если имя было задано в ручную и при этом не верно - без слэша)
.Names(sPath_in_Names).Value = sDirPath ' запомнить путь сохранения копий в коллекции .Names под именем sPath_in_Names
sExp = Right(.Name, Len(.Name) - InStrRev(.Name, ".") + 1) ' расширение файла вместе с точкой (например, ".xls")
sMainName = Left(.Name, Len(.Name) - Len(sExp))
Do
FileName = sDirPath & sMainName & "(" & i & ")" & sExp: i = i + 1
Loop While Dir(FileName) <> "" ' пока имя не будет уникальным в папке
FileName = Application.GetSaveAsFilename(InitialFileName:=FileName, _
FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
Title:="Сохранение копии файла") 'задать путь сохранения и имя копии файла в окне выбора
If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем
sDirPath = Left(FileName, InStrRev(FileName, "\")) ' путь к папке сохранения копий без имени файла
.Names(sPath_in_Names).Value = sDirPath ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names
.SaveCopyAs FileName
End With
End Sub
С уважением,
Алексей
MS Excel 2003 - the best.
Sub Save_Copy_As_I()
'---------------------------------------------------------------------------------------
' Procedure : Save_Copy_As_I
' Author : Alex_ST
' Topic_HEADER : Сохранить копию текущего файла, запомнив папку для сохранения
' Topic_URL : http://www.excelworld.ru/forum/2-1639-18265-16-1335949159
' DateTime : 02.05.12, 12:59
' Purpose : Сохранение копии активного файла с автоматическим увеличением суффикса (номера копии)
' Notes : Путь сохранения копий хранится в коллекции .Names книги (в именованном диапазоне)
'---------------------------------------------------------------------------------------
Const sPath_in_Names = "Path4SaveCopyAs" ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла
Dim sDirPath$, sExp$, sMainName$, FileName, i%
With ActiveWorkbook
On Error Resume Next
sDirPath = .Names(sPath_in_Names).Value ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names
If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Path & "\" ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным ActiveWorkbook.Path
sDirPath = Mid(sDirPath, 3, Len(sDirPath) - 3) ' убрать из считанного значения в начале "= и в конце "
sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\") ' на всякий случай (если имя было задано в ручную и при этом не верно - без слэша)
.Names(sPath_in_Names).Value = sDirPath ' запомнить путь сохранения копий в коллекции .Names под именем sPath_in_Names
sExp = Right(.Name, Len(.Name) - InStrRev(.Name, ".") + 1) ' расширение файла вместе с точкой (например, ".xls")
sMainName = Left(.Name, Len(.Name) - Len(sExp))
Do
FileName = sDirPath & sMainName & "(" & i & ")" & sExp: i = i + 1
Loop While Dir(FileName) <> "" ' пока имя не будет уникальным в папке
FileName = Application.GetSaveAsFilename(InitialFileName:=FileName, _
FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
Title:="Сохранение копии файла") 'задать путь сохранения и имя копии файла в окне выбора
If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем
sDirPath = Left(FileName, InStrRev(FileName, "\")) ' путь к папке сохранения копий без имени файла
.Names(sPath_in_Names).Value = sDirPath ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names
.SaveCopyAs FileName
End With
End Sub
Вадим, ну я же не с нуля набирал, а подпиливал свой же Макрос Save_Copy_As (в тот топик, к стати, я и этот макрос добавил чтобы "Готовое решение" было на любой вкус ).
А там больше всяких примочек для удобства, проверок и "защит от дурака", чем собственно главного действия - сохранения копии. А все эти прибамбасы остались практически неизменными.
VanDerGraat, пожалуйста, юзайте.
Но с суффиксом - датой и временем, ИМХО всё-таки лучше. Т.к. при сортировке в проводнике Виндов самый последний файл окажется самым нижним. А вот при обычной нумерации всё красиво будет только до тех пор, пока копий в папке будет до 10 (с суффиксами от 0 до 9).
А если больше, то сортировка в окне начнёт сбиваться (ведь она идёт по тексту в именах файлов).
Чтобы этого не было нужно ограничиться максимальным количеством копий, например в 1000 и присваивать суффиксы типа 001, 002, . 998, 999.
Но даже если это сделать, то опять же возникнут проблемы когда Вы через некоторое время, сохранив уже сотню копий, захотите удалить совсем старые и уже не нужные.
После такого удаления макрос начнёт нумерацию с 000 и продолжит её пока не упрётся в Ваш самый старый из оставленных не стёртыми файлов.
Так что чистить хранилище лучше только полностью.
А вот при времени и дате никаких ограничений нет. Потому я изначально макрос так и сделал.
Вадим, ну я же не с нуля набирал, а подпиливал свой же Макрос Save_Copy_As (в тот топик, к стати, я и этот макрос добавил чтобы "Готовое решение" было на любой вкус ).
А там больше всяких примочек для удобства, проверок и "защит от дурака", чем собственно главного действия - сохранения копии. А все эти прибамбасы остались практически неизменными.
VanDerGraat, пожалуйста, юзайте.
Но с суффиксом - датой и временем, ИМХО всё-таки лучше. Т.к. при сортировке в проводнике Виндов самый последний файл окажется самым нижним. А вот при обычной нумерации всё красиво будет только до тех пор, пока копий в папке будет до 10 (с суффиксами от 0 до 9).
А если больше, то сортировка в окне начнёт сбиваться (ведь она идёт по тексту в именах файлов).
Чтобы этого не было нужно ограничиться максимальным количеством копий, например в 1000 и присваивать суффиксы типа 001, 002, . 998, 999.
Но даже если это сделать, то опять же возникнут проблемы когда Вы через некоторое время, сохранив уже сотню копий, захотите удалить совсем старые и уже не нужные.
После такого удаления макрос начнёт нумерацию с 000 и продолжит её пока не упрётся в Ваш самый старый из оставленных не стёртыми файлов.
Так что чистить хранилище лучше только полностью.
А вот при времени и дате никаких ограничений нет. Потому я изначально макрос так и сделал. Alex_ST
С уважением,
Алексей
MS Excel 2003 - the best.
Привет, сейчас мы рассмотрим ситуацию, когда у Вас возникла необходимость в Excel сохранять файл с определенным названием, которое необходимо сформировать из значения ячейки или даже нескольких. В этой заметке я приведу простой пример реализации данной задачи.
Исходные данные
Сначала давайте разберем исходные данные, которые я буду использовать в примерах. Пусть это будет некая абстракция марок автомобилей с указанием их VIN номера.
Примечание! Я использую Excel 2013.
В зависимости от конкретных требований и условий, задачу можно реализовать по-разному, хотя принцип будет один и тот же, в этой статье мы рассмотрим несколько вариаций реализации.
Начнем мы с самой простой ситуации, когда заранее известна ячейка, на основе которой будет сформировано имя файла, и адрес этой ячейки изменяться не будет.
Сохранение файла Excel с названием из ячейки — с привязкой к этой ячейке
Итак, данные у нас есть, теперь необходимо написать процедуру на VBA (макрос), которая брала бы значение из конкретной ячейки, в данном случае это будет ячейка B14, и присваивала бы это значение имени файла.
Ниже представлен код процедуры, я его подробно прокомментировал. Единственное скажу, что я во всех примерах сохраняю новые файлы без макросов (расширение .xlsx), т.е. по факту будет один файл с поддержкой макросов, а все производные — без.
Если нужно сохранять макрос в каждом файле, т.е. файлы с поддержкой макросов (расширение .xlsm), то необходимо просто указать другой тип файла при сохранении, а именно xlOpenXMLWorkbookMacroEnabled, в процедурах в комментариях я это указываю.
Открываем в Excel редактор Visual Basic, и вставляем код следующей процедуры в исходный код этой книги (ЭтаКнига, открыть двойным кликом) или в модуль, который Вы предварительно должны создать.
Примечание! Для того чтобы открыть редактор Visual Basic в Excel, необходимо перейти на вкладку «Разработчик» и нажать на кнопку «Visual Basic». Файл Excel с кодом процедуры необходимо сохранить с типом «Книга Excel с поддержкой макросов».
Код процедуры
После сохранения файла запустите макрос («Макросы -> Выполнить -> SaveFile»).
Добавление кнопки в Excel для запуска макроса
Каждый раз открывать окно с макросами и выбирать нужный макрос не очень удобно, поэтому можно легко добавить кнопку где-нибудь рядом с данными и просто нажимать ее. Это делается следующим образом «Вкладка Разработчик -> Вставить -> Кнопка (элемент управления формы)».
Затем выберите место, где вставить кнопку, и нажмите туда. После этого появится окно назначения действия, т.е. нужно выбрать, какой макрос запускать при нажатии этой кнопки, выбираем наш макрос, т.е. SaveFile, и нажимаем «ОК».
В итоге появится кнопка с названием «Кнопка», это название лучше изменить, например, на «Сохранить файл». Для этого нажмите правой кнопкой мыши на кнопку и выберите настройки «Изменить текст». В итоге у Вас должно получиться что-то вроде этого.
Сохранение файла Excel с названием из ячейки — без привязки к ячейке
Теперь давайте представим, что заранее мы не можем определить, какая именно ячейка будет формировать название файла (может B14, а может и нет), поэтому мы можем немного скорректировать алгоритм таким образом, чтобы он брал значение из ячейки, которая является активной, но в этом случае Вы, конечно же, предварительно, должны выбрать ее (т.е. встать на нее).
Замените код процедуры следующим кодом, который совсем немного, но изменен.
Проверяем работу, становимся на нужную ячейку, и запускаем макрос (в процедуре я добавил проверку, если выбрана пустая ячейка, возникнет ошибка).
Как видим, все отработало.
Сохранение файла Excel с названием, которое сформировано из значений двух ячеек
Теперь представим, что нам нужно сформировать файл с названием из значений двух ячеек. Например, в нашем случае это может быть «Марка Авто – VIN Номер», в качестве разделителя я указал символ – (дефис), но им может выступать любой символ или вовсе отсутствовать.
В этом примере я покажу, как можно это реализовать с привязкой к конкретным ячейкам, в нашем случае B14 и D14.
Код процедуры в данном случае будет выглядеть следующим образом.
Все ОК, файл создан.
Если вдруг нужно реализовать без привязки к конкретным ячейкам, например, значения хранятся в определённых столбцах, но конкретная строка неизвестна Вам заранее. Например, у меня несколько строк со значениями, и какие конкретно значения взять за основу названия файла, я хочу указывать самостоятельно, непосредственно перед сохранением, но при этом не редактировать код процедуры.
Для этого мы снова внесем изменения в нашу процедуру, которая будет работать от активной ячейки (смещение от активной ячейки), только с условием того, что выбран столбец с теми значениями, которые необходимо использовать.
Код процедуры
Становитесь на любую ячейку со значением в столбце B, и запускайте макрос.
Про сборку листов из нескольких книг в одну текущую я уже писал здесь. Теперь разберем решение обратной задачи: есть одна книга Excel, которую нужно "разобрать", т.е. сохранить каждый лист как отдельный файл для дальнейшего использования.
Примеров подобного из реальной жизни можно привести массу. Например, файл-отчет с листами-филиалами нужно разделить на отдельные книги по листам, чтобы передать затем данные в каждый филиал и т.д.
Если делать эту процедуру вручную, то придется для каждого листа выполнить немаленькую цепочку действий (выбрать лист, правой кнопкой по ярлычку листа, выбрать Копировать, указать отдельный предварительно созданный пустой файл и т.д.) Гораздо проще использовать короткий макрос, автоматизирующий эти действия.
Способ 1. Простое разделение
Нажмите сочетание Alt+F11 или выберите в меню Сервис - Макрос - Редактор Visual Basic (Tools - Macro - Visual Basic Editor) , вставьте новый модуль через меню Insert - Module и скопируйте туда текст этого макроса:
Если теперь выйти из редактора Visual Basic и вернуться в Excel, а затем запустить наш макрос (Alt+F8), то все листы из текущей книги будут разбиты по отдельным новым созданным книгам.
Способ 2. Разделение с сохранением
При необходимости, можно созданные книги сразу же сохранять под именами листов. Для этого макрос придется немного изменить, добавив команду сохранения в цикл:
Этот макрос сохраняет новые книги-листы в ту же папку, где лежал исходный файл. При необходимости сохранения в другое место, замените wb.Path на свой путь в кавычках, например "D:\Отчеты\2012" и т.п.
Если нужно сохранять файлы не в стандартном формате книги Excel (xlsx), а в других (xls, xlsm, xlsb, txt и т.д.), то кроме очевидного изменения расширения на нужное, потребуется добавить еще и уточнение формата файла - параметр FileFormat:
Для основных типов файлов значения параметра FileFormat следующие:
- XLSX = 51
- XLSM = 52
- XLSB = 50
- XLS = 56
- TXT = 42
Способ 3. Сохранение в новые книги только выделенных листов
Если вы хотите раскидать по файлам не все листы в вашей книге, а только некоторые, то макрос придется немного изменить. Выделите нужные вам листы в книге, удерживая на клавиатуре клавишу Ctrl или Shift и запустите приведенный ниже макрос:
Создавать новое окно и копировать через него, а не напрямую, приходится потому, что Excel не умеет копировать группу листов, если среди них есть листы с умными таблицами. Копирование через новое окно позволяет такую проблему обойти.
Способ 4. Сохранение только выделенных листов в новый файл
Во всех описанных выше способах каждый лист сохранялся в свой отдельный файл. Если же вы хотите сохранить в отдельный новый файл сразу группу выделенных предварительно листов, то нам потребуется слегка видоизменить наш макрос:
Способ 5. Сохранение листов как отдельных PDF-файлов
- для этого используется уже другой метод (ExportAsFixedFormat а не Copy)
- листы выводятся в PDF с параметрами печати, настроенными на вкладке Разметка страницы (Page Layout)
- книга должна быть сохранена на момент экспорта
Нужный нам код будет выглядеть следующим образом:
Способ 6. Готовый макрос из надстройки PLEX
Если лень или нет времени внедрять все вышеописанное, то можно воспользоваться готовым макросом из моей надстройки PLEX:
В этой статье я хотел бы рассказать как средствами VBA переименовать, переместить или скопировать файл. В принципе методы переименования, перемещения и копирования, так сказать, встроены в VBA. Это значит что можно без вызова сторонних объектов переименовать, переместить или копировать любой файл. Все это делается при помощи всего двух команд: FileCopy и Name [Исходный файл] As [Новый файл] . Притом команда FileCopy выполняет только копирование, а Name [Исходный файл] As [Новый файл] - как переименование, так и перемещение. Разница лишь в том, что при переименовании мы указываем только новое имя файла, а при перемещении - другую директорию(папку), в которую следует переместить файл. Плюс рассмотрим пример удаления файла.
Так же разберем методы копирования, перемещения, переименования и удаления файлов и папок через библиотеку FileSystemObject (FSO).
Работа с файлами встроенными командами VBA
Работа с файлами через объект FileSystemObject (FSO)
Работа с папками через объект FileSystemObject (FSO)
Во всех примерах работы с файлами встроенными функциями будет присутствовать проверка на наличие файла по указанному пути. Делать это будем при помощи встроенной функции Dir([PathName],[Attributes]) .
PathName - указывается полный путь к файлу
Attributes - указывается признак свойств файла. Вообще их несколько(скрытый, архивный и т.п.), но нас для наших задач будет интересовать пока только один: 16(vbDirectory). Он отвечает за проверку папок и файлов без специальных свойств(т.е. не архивные, не скрытые и т.д.). Хотя по сути его можно вообще не указывать, и тогда будет по умолчанию применен атрибут 0(vbNormal) - проверка файлов без определенных свойств. Ни в том ни в другом случае ошибкой это не будет.
Sub Copy_File() Dim sFileName As String, sNewFileName As String sFileName = "C:\WWW.xls" 'имя файла для копирования sNewFileName = "D:\WWW.xls" 'имя копируемого файла. Директория(в данном случае диск D) должна существовать If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If FileCopy sFileName, sNewFileName 'копируем файл MsgBox "Файл скопирован", vbInformation, "www.excel-vba.ru" End Sub
Sub Move_File() Dim sFileName As String, sNewFileName As String sFileName = "C:\WWW.xls" 'имя исходного файла sNewFileName = "D:\WWW.xls" 'имя файла для перемещения. Директория(в данном случае диск D) должна существовать If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If Name sFileName As sNewFileName 'перемещаем файл MsgBox "Файл перемещен", vbInformation, "www.excel-vba.ru" End Sub
Sub Rename_File() Dim sFileName As String, sNewFileName As String sFileName = "C:\WWW.xls" 'имя исходного файла sNewFileName = "C:\WWW1.xls" 'имя файла для переименования If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If Name sFileName As sNewFileName 'переименовываем файл MsgBox "Файл переименован", vbInformation, "www.excel-vba.ru" End Sub
Sub Delete_File() Dim sFileName As String sFileName = "C:\WWW.xls" 'имя файла для удаления If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If Kill sFileName 'удаляем файл MsgBox "Файл удален", vbInformation, "www.excel-vba.ru" End Sub
Как видно ничего сложного.
Так же можно проделать те же операции с файлами при помощи объекта FileSystemObject. Строк кода несколько больше и выполняться операции будут медленнее(хотя вряд ли это будет заметно на примере одного файла). Однако есть существенный плюс - при помощи FileSystemObject можно корректно производить операции с файлами и папками на сетевом диске. Хотя та же Dir(sFileName, 16) часто выдает ошибку при работе с сетевыми дисками.
Прежде всего следует, я думаю, пояснить что за зверь такой - FileSystemObject.
FileSystemObject (FSO) - содержится в библиотеке типов Scripting, расположенной в файле библиотеки scrrun.dll. Объектная модель FSO дает возможность создавать, изменять, перемещать и удалять папки и файлы, собирать о них различную информацию: имена, атрибуты, даты создания или изменения и т.д. Чтобы работать с FSO необходимо создать переменную со ссылкой на объект библиотеки. Сделать это можно двумя способами: через ранее связывание и позднее. Я не буду сейчас вдаваться в подробности этих методов - тема довольно обширная и я опишу её в другой статье.
Ранее связывание: для начала необходимо подключить библиотеку Microsoft Scripting Runtime. Делается это в редакторе VBA: References-находите там Microsoft Scripting Runtime и подключаете. Объявлять переменную FSO при раннем связывании следует так:
Dim objFSO As New FileSystemObject
Плюсы раннего связывания: с помощью Object Browser можно просмотреть список объектов, свойств, методов, событий и констант, включенных в FSO. Но есть значительный минус: если планируется использовать программу на нескольких компьютерах, то есть большая вероятность получить ошибку(читать подробнее).
Позднее связывание: ничего нигде не надо подключать, а просто используем метод CreateObject(именно этот способ используется мной в примерах ниже). Методы таким образом просмотреть не получится, но зато работать будет без проблем на любых компьютерах без дополнительных действий.
Sub Copy_File() Dim objFSO As Object, objFile As Object Dim sFileName As String, sNewFileName As String sFileName = "C:\WWW.xls" 'имя исходного файла sNewFileName = "D:\WWW.xls" 'имя файла для переименования 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие файла по указанному пути If objFSO.FileExists(sFileName) = False Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If 'копируем файл Set objFile = objFSO.GetFile(sFileName) objFile.Copy sNewFileName MsgBox "Файл скопирован", vbInformation, "www.excel-vba.ru" End Sub
Sub Move_File() Dim objFSO As Object, objFile As Object Dim sFileName As String, sNewFileName As String sFileName = "C:\WWW.xls" 'имя исходного файла sNewFileName = "D:\WWW.xls" 'имя файла для переименования 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие файла по указанному пути If objFSO.FileExists(sFileName) = False Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If 'перемещаем файл Set objFile = objFSO.GetFile(sFileName) objFile.Move sNewFileName MsgBox "Файл перемещен", vbInformation, "www.excel-vba.ru" End Sub
Sub Rename_File() Dim objFSO As Object, objFile As Object Dim sFileName As String, sNewFileName As String sFileName = "C:\WWW.xls" 'имя исходного файла sNewFileName = "WWW1.xls" 'имя файла для переименования 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие файла по указанному пути If objFSO.FileExists(sFileName) = False Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If 'переименовываем файл Set objFile = objFSO.GetFile(sFileName) objFile.Name = sNewFileName MsgBox "Файл переименован", vbInformation, "www.excel-vba.ru" End Sub
Хочу обратить внимание, что при переименовании файла через FileSystemObject необходимо указать только имя нового файла - путь указывать не надо. Иначе получите ошибку.
Sub Delete_File() Dim objFSO As Object, objFile As Object Dim sFileName As String sFileName = "C:\WWW.xls" 'имя файла для удаления 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие файла по указанному пути If objFSO.FileExists(sFileName) = False Then MsgBox "Нет такого файла", vbCritical, "www.excel-vba.ru" Exit Sub End If 'удаляем файл Set objFile = objFSO.GetFile(sFileName) objFile.Delete MsgBox "Файл удален", vbInformation, "www.excel-vba.ru" End Sub
Точно так же можно перемещать, копировать и удалять целые папки:
Sub Copy_Folder() Dim objFSO As Object Dim sFolderName As String, sNewFolderName As String sFolderName = "C:\test" 'имя исходной папки sNewFolderName = "D:\tmp\" 'имя папки, в которую копируем(нужен слеш на конце) 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие папки по указанному пути If objFSO.FolderExists(sFolderName) = False Then MsgBox "Нет такой папки", vbCritical, "www.excel-vba.ru" Exit Sub End If 'копируем папку objFSO.CopyFolder sFolderName, sNewFolderName MsgBox "Папка скопирована", vbInformation, "www.excel-vba.ru" End Sub
Sub Move_Folder() Dim objFSO As Object Dim sFolderName As String, sNewFolderName As String sFolderName = "C:\test" 'имя исходной папки sNewFolderName = "C:\tmp\test\" 'имя папки, в которую перемещаем(нужен слеш на конце) 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие папки по указанному пути If objFSO.FolderExists(sFolderName) = False Then MsgBox "Нет такой папки", vbCritical, "www.excel-vba.ru" Exit Sub End If 'перемещаем папку objFSO.MoveFolder sFolderName, sNewFolderName MsgBox "Папка перемещена", vbInformation, "www.excel-vba.ru" End Sub
Sub Rename_Folder() Dim objFSO As Object, objFolder As Object Dim sFolderName As String, sNewFolderName As String sFolderName = "C:\test\" 'имя исходной папки 'имя папки для переименования(только имя, без полного пути) sNewFolderName = "new folder name" 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие папки по указанному пути If objFSO.FolderExists(sFolderName) = False Then MsgBox "Нет такой папки", vbCritical, "www.excel-vba.ru" Exit Sub End If 'переименовываем папку 'получаем доступ к объекту Folder(папка) Set objFolder = objFSO.GetFolder(sFolderName) 'назначаем новое имя objFolder.Name = sNewFolderName MsgBox "Папка переименована", vbInformation, "www.excel-vba.ru" End Sub
Sub Delete_Folder() Dim objFSO As Object, objFolder As Object Dim sFolderName As String sFolderName = "C:\test\" 'имя папки для удаления 'создаем объект FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'проверяем наличие папки по указанному пути If objFSO.FolderExists(sFolderName) = False Then MsgBox "Нет такой папки", vbCritical, "www.excel-vba.ru" Exit Sub End If 'удаляем папку objFSO.DeleteFolder sFolderName MsgBox "Папка удалена", vbInformation, "www.excel-vba.ru" End Sub
FSO, конечно, способен на большее - но цель данной статьи была показать основные операции с папками и файлами как стандартными методами, так и более продвинутыми.
Достаточно часто появляется вопрос: как извлечь данные из закрытой книги Excel через VBA? Звучит может быть странновато, но это так: вопрос регулярно поднимается на форумах. Собственно, именно в связи с этим и появилась на свет данная статья. В принципе ничего сложного в задаче нет. При этом получить данные можно разными способами, в том числе при помощи функций пользователя(UDF).
Хотя если вдаваться в технические подробности, то получить данные из закрытой книги вообще нельзя. Так или иначе, на уровне системы файл все равно открывается, различие лишь в том как именно и к чему при этом предоставляется доступ. Поэтому переозвучим классическую постановку задачи в более распространенную в жизни: "Как получить данные из книги, не открывая её так, чтобы об этом узнал пользователь"
Попробуем разобраться с некоторыми методами, их плюсами и минусами:
Получение данных из закрытой книги при помощи процедуры VBA
Sub Get_Value_From_Close_Book_Formula() Dim sPath As String, sFile As String, sShName As String sPath = "C:\Documents and Settings\" '" sFile = "Книга1.xls" '" sShName = "Лист1" '" Application.DisplayAlerts = 0 With Range("A1:A100") .Formula = "='" & sPath & "[" & sFile & "]" & sShName & "'!" & "A1" '" '"A1" - указывается начальная ячейка диапазона, из которого необходимо получить значения .Value = .Value End With Application.DisplayAlerts = 1 End Sub
Данный код работает достаточно медленно, но с его помощью можно "вытащить" из закрытой книги значения сразу нескольких ячеек. Код ниже работает быстрее, но с его помощью можно извлечь значения лишь одной ячейки:
Sub Get_Value_From_Close_Book_Excel4Macro() Dim sPath As String, sFile As String, sShName As String Dim sAddress As String, vData sPath = "C:\Documents and Settings\" '" sFile = "Книга1.xls" '" sShName = "Лист1" '" sAddress = "'" & sPath & "[" & sFile & "]" & sShName & "'!" & Range("A1").Address(ReferenceStyle:=xlR1C1) '" vData = ExecuteExcel4Macro(sAddress) End Sub
Если честно, сам я не очень-то люблю ни один из данных методов, т.к. они совершенно лишены гибкости. С их помощью можно получить исключительно значения ячеек. Форматы, формулы или другие свойства ячеек получить уже не получится. Поэтому я предпочитаю открывать книгу и копировать то, что мне надо. Делаю это, скрывая от пользователя при помощи свойства ScreenUpdating объекта Application.
Sub Get_Value_From_Close_Book() Dim sShName As String, sAddress As String, vData Dim objCloseBook As Workbook 'Отключаем обновление экрана Application.ScreenUpdating = False Set objCloseBook = Workbooks.Open("C:\Documents and Settings\Книга1.xls") sAddress = "A1:C100" 'или одна ячейка - "A1" 'получаем значение vData = Sheets("Лист1").Range(sAddress).Value 'Записываем данные на активный лист книги, 'с которой запустили макрос If IsArray(vData) Then [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData Else [A1] = vData End If 'если надо копировать ячейки с форматами, 'то можно использовать стандартные методы копирования вставки 'objCloseBook.Sheets("Лист1").Range(sAddress).Copy '[A1].PasteSpecial xlPasteValues 'вставляем значения '[A1].PasteSpecial xlPasteFormats 'вставляем форматы 'закрываем книгу(из которой получали значения) без сохранения objCloseBook.Close False 'Включаем обновление экрана Application.ScreenUpdating = True End Sub
Есть и более экзотический метод - при помощи GetObject:
Sub Get_Value_From_Close_Book2() Dim sShName As String, sAddress As String, vData Dim objCloseBook As Object 'Отключаем обновление экрана Application.ScreenUpdating = False Set objCloseBook = GetObject("C:\Documents and Settings\Книга1.xls") sAddress = "A1:C100" 'или одна ячейка - "A1" 'получаем значение vData = objCloseBook.Sheets("Лист1").Range(sAddress).Value 'Записываем данные на активный лист книги, 'с которой запустили макрос If IsArray(vData) Then [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData Else [A1] = vData End If 'если надо копировать ячейки с форматами, 'то можно использовать стандартные методы копирования вставки 'objCloseBook.Sheets("Лист1").Range(sAddress).Copy '[A1].PasteSpecial xlPasteValues 'вставляем значения '[A1].PasteSpecial xlPasteFormats 'вставляем форматы 'закрываем книгу(из которой получали значения) без сохранения objCloseBook.Close False 'Включаем обновление экрана Application.ScreenUpdating = True End Sub
При таком подходе пользователь разницы не увидит, а действия можно производить с ячейками разные: и сравнение, и отбор по критериям, и фильтровать, и сортировать и т.д. Плюс из книги можно переносить не только значения ячеек, но и форматы, формулы. Но выбирать метод получения значений из закрытых книг вам. Все зависит от ситуации. Все указанные коды работают. Если не работают - то проверьте верно ли указаны все исходные данные(имя книги и расширение, имя листа, путь к папке с книгой).
Получение данных из закрытой книги при помощи UDF
Тот же код, что уже был рассмотрен выше, но оформленный в виде UDF(функции пользователя):
Function Get_Value_From_Close_Book(sWb As String, sShName As String, sAddress As String) Dim vData, objCloseBook As Object Set objCloseBook = GetObject(sWb) 'получаем значение vData = objCloseBook.Sheets(sShName).Range(sAddress).Value objCloseBook.Close False Set objCloseBook = Nothing 'Возвращаем данные в ячейку с функцией Get_Value_From_Close_Book = vData End Function
Синтаксис функции (вызов с листа):
=Get_Value_From_Close_Book("C:\Книга1.xls";"Лист1";"B1")
sWb - полный путь до книги, данные из которой необходимо извлечь ( "C:\Книга1.xls" )
sShName - имя листа в указанной книге, данные из которого необходимо извлечь ( "Лист1" )
sAddress - адрес ячейки(диапазона) данные которой необходимо получить ( "B1" )
Чтобы получить массив ячеек(например B1:B10), необходимо выделить необходимое количество ячеек и ввести в них эту функцию, как формулу массива.
Думаю, не надо пояснять, что любой аргумент может быть задан не статичным текстом, а ссылкой на ячейку с этим текстом. Именно в этом и преимущество использования именно функций, а не процедур.
ПОЛУЧЕНИЕ ДАННЫХ ПРИ ПОМОЩИ ЗАПРОСА ADO
Так же есть еще один достаточно экзотический метод получения данных из действительно закрытой книги - через ADO(ActiveX Data Objects). По сути это получение данных через запрос SQL, используя для этого технологию ADO.
'--------------------------------------------------------------------------------------- ' Procedure : Extract_Value_ADO ' DateTime : 02.07.2014 16:47 ' Author : The_Prist(Щербаков Дмитрий) ' http://www.excel-vba.ru ' Purpose : Функция получения данных из закрытой книги при помощи ADO ' в таком виде не может быть использована вызовом с листа '--------------------------------------------------------------------------------------- Function Extract_Value_ADO(sPath As String, sFileName As String, sShName As String, sRng As String) Dim objADO_Con As Object, objRS As Object Dim sFullFileName As String, sADORng As String 'проверяем наличие слеша в пути к файлу If Right(sPath, 1) <> "\" Then sPath = sPath & "\" 'если ячейка только одна - меняем вид адресации на ячейка:ячейка, как того требует ADO If Range(sRng).Count = 1 Then sADORng = sRng & ":" & sRng Else sADORng = sRng End If sFullFileName = sPath & sFileName With CreateObject("ADODB.Connection") 'подключаемся к файлу .Open "Driver=;ReadOnly=1;DBQ=" & sFullFileName & ";" 'извлекаем записи из указанного диапазона в objRS Set objRS = .Execute("select * FROM [" & sShName & "$" & sADORng & "]") 'выгружаем извлеченные данные на активный лист, начиная с ячейки А1 Cells(1, 1).CopyFromRecordset objRS 'Extract_Value_ADO = objRS.Fields(0).Value End With Set objRS = Nothing End Function
Вызывать эту функцию следует из другой процедуры или функции. Пример процедуры, для вызова этой функции:
Для вызова функции Extract_Value_ADO непосредственно с листа(в виде функции UDF) придется несколько изменить приведенный выше код функции, либо извлекать функцией значение только одной ячейки, что будет не очень экономично с точки зрения ресурсов и использование для этого ADO будет слишком неоправданным. Если кому необходимо, то для вызова функции с ячейки листа и возврата значения одной ячейки, необходимо заменить строку:
Cells(1, 1).CopyFromRecordset objRS
Синтаксис вызова с листа в таком случае будет следующим:
=Extract_Value_ADO("C:\"; "Книга1.xls"; "Лист1"; "A1")
Важно: если данные извлекаются только из одной ячейки, то следует указать две ячейки: А1:А2 . Это особенность работы с запросами
Если же необходимо извлекать данные диапазона ячеек, то в этом случае можно применить такую функцию:
'--------------------------------------------------------------------------------------- ' Procedure : Extract_Value_ADO ' DateTime : 02.07.2014 16:47 ' Author : The_Prist(Щербаков Дмитрий) ' http://www.excel-vba.ru ' Purpose : Функция получения данных из закрытой книги при помощи ADO ' вызывается с листа как функция массива(если получаем данные с диапазона) '--------------------------------------------------------------------------------------- Function Extract_Value_ADO_Sh(sPath As String, sFileName As String, sShName As String, sRng As String) Dim objADO_Con As Object, objRS As Object Dim sFullFileName As String, sADORng As String Dim avTmp(), avRes(), li As Long, lr As Long, lc As Long 'проверяем наличие слеша в пути к файлу If Right(sPath, 1) <> "\" Then sPath = sPath & "\" 'если ячейка только одна - меняем вид адресации на ячейка:ячейка, как того требует ADO If Range(sRng).Count = 1 Then sADORng = sRng & ":" & sRng Else sADORng = sRng End If sFullFileName = sPath & sFileName With CreateObject("ADODB.Connection") 'подключаемся к файлу .Open "Driver=;ReadOnly=1;DBQ=" & sFullFileName & ";" 'получаем кол-во строк в запросе Set objRS = .Execute("SELECT COUNT(*) FROM [" & sShName & "$" & sADORng & "]") li = objRS.Fields(0).Value 'извлекаем записи из указанного диапазона в objRS Set objRS = .Execute("SELECT * FROM [" & sShName & "$" & sADORng & "]") 'выгружаем извлеченные данные на активный лист, начиная с ячейки А1 ReDim avRes(1 To li, 1 To objRS.Fields.Count) avTmp = objRS.getrows(li, 0) 'получаем массив данных запроса For lr = 0 To li - 1 'цикл по строкам For lc = 0 To UBound(avTmp, 1) 'цикл по столбцам 'значения Null не допускаются, поэтому приходится их подменять до выгрузки на лист If IsNull(avTmp(lc, lr)) Then avTmp(lc, lr) = Empty End If avRes(lr + 1, lc + 1) = avTmp(lc, lr) Next lc Next lr End With Extract_Value_ADO_Sh = avRes Set objRS = Nothing End Function
Синтаксис вызова с листа точно такой же как и в функции выше, только нужно будет выделить необходимое количество ячеек и ввести в них эту функцию, как формулу массива.:
=Extract_Value_ADO_Sh("C:\"; "Книга1.xls"; "Лист1"; "A1:B10")
sPath - путь к папке с книгой, данные из которой необходимо извлечь ( "C:\" )
sWb - имя книги, включая расширение(.xls в примере), данные из которой необходимо извлечь ( "Книга1.xls" )
sShName - имя листа в указанной книге, данные из которого необходимо извлечь ( "Лист1" )
sAddress - адрес ячейки(диапазона) данные которой необходимо получить ( "A1" )
Важно: если данные извлекаются только из одной строки, то следует все равно указать минимум две строки: А1:B10 . Это особенность работы с запросами. При попытке указать только одну строку А1:A10 функция вернет значение ошибки. При этом первая строка воспринимается как заголовки. Т.е. данные должны начинаться как минимум со второй строк(A2), а в A1 - заголовок
Хоть эта функция имеет определенные недостатки - она может быть в разы быстрее предыдущей.
Получение данных из закрытой книги при помощи Power Query
Если еще не работали с надстройкой PowerQuery и не знаете что это такое, то для начала лучше ознакомиться со статьей: Power Query - что такое и почему её необходимо использовать в работе?
Переходим на вкладку Данные(для Excel ниже 2016 вкладка PowerQuery) -Получить данные -Из файла -Из книги
Выбираем нужный лист
Если необходимы данные всего листа, то внизу этого окна нажимаем кнопку Загрузить. Все, через пару секунд все данные выбранного листа будут помещены на новый лист текущей книги в умную таблицу.
Читайте также: