| Процедура имеет 5 параметров:
1. FullPath — обязательный. Полный путь для сохранения файла
2. FolderPath — не обязательный. Путь к заведомо существующей папке, значение по умолчанию — ThisWorkbook.Path (путь к папке с макросом)
3. wb — не обязательный. Сохраняемая книга, по умолчанию — ActiveWorkbook. Важно! Параметр представляет собой именно книгу, а не её имя, индекс или кодовое имя. Workbooks("Книга1"), Workbooks(1) или Workbooks(Книга1), но не "Книга1".
4. Form — формат сохранения, не обязательный. По умолчанию файлы форматов .xls, .xlsx, .xlsm, .xlsb сохраняются в том же формате, остальные файлы — в формате .xls или .xlsx, в зависимости от версии Excel
5. PathErr — не обязательный отладочный параметр. Определяет, что делать, если не существует путь, заданный параметром FolderPath. При значении True путь создаётся начиная от диска, при значении False — приложение закрывается.
Sub PathCreator(ByVal FullPath As String, Optional FolderPath As String = "", Optional wb As Workbook = Nothing, Optional Form = "", Optional PathErr As Boolean = True)
Dim PathBody As String
FolderPath = IIf(FolderPath = "", ThisWorkbook.Path, FolderPath)
Set wb = IIf(wb Is Nothing, ActiveWorkbook, wb)
If Form = "" Then
Select Case Right(wb.Name, Len(wb.Name) - InStr(1, wb.Name, ".", vbTextCompare))
Case "xlsx"
Form = xlOpenXMLWorkbook
Case "xlsm"
Form = xlOpenXMLWorkbookMacroEnabled
Case "xlsb"
Form = xlExcel12
Case "xls"
Form = xlExcel8
Case Else
If Application.Version < 12 Then
Form = xlExcel8
Else: Form = xlOpenXMLWorkbook
End If
End Select
End If
On Error Resume Next
PathBody = Dir(FolderPath, vbDirectory)
If PathBody = "" Or InStr(1, FullPath, FolderPath, vbTextCompare) <> 1 Then
If PathErr Then
FolderPath = Left(FolderPath, InStr(1, FolderPath, Application.PathSeparator, vbTextCompare))
Else
MsgBox "Головной путь " & FolderPath & " не существует или не соответствует полному пути"
Application.Quit
End If
End If
Do
Err.Clear
PathBody = Right(FullPath, Len(FullPath) - Len(FolderPath) - 1)
FolderPath = FolderPath & Application.PathSeparator & Left(PathBody, InStr(1, PathBody, Application.PathSeparator, vbTextCompare) - 1)
On Error Resume Next
wb.SaveAs Filename:=FullPath, FileFormat:=Form, CreateBackup:=False
If Err.Number <> 0 Then
Err.Clear
On Error Resume Next
MkDir FolderPath
On Error Resume Next
wb.SaveAs Filename:=FullPath, FileFormat:=Form, CreateBackup:=False
End If
If InStr(1, PathBody, Application.PathSeparator, vbTextCompare) = 0 And Err.Number <> 0 Then
If MsgBox(prompt:="Файл с именем " & PathBody & " уже открыт. Закрыть его?") = vbYes Then
Workbooks(PathBody).Close
wb.SaveAs Filename:=FullPath, FileFormat:=Form, CreateBackup:=False
Else: Application.Quit
End If
End If
Loop While Err.Number <> 0
End Sub |
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
