Помогите пожалуйста! Есть документ в котором с помощью функции СЛЧИС() просчитываются некоторые значения. По данным из этого документа на основе шаблона (*.xlt) создается книга с неизменными, конкретными значениями. Для этой цели собран следующий код, а для удобства новая книга автоматически сохраняется по пути в зависимости от данных на листе.
В принципе, работает как надо, однако есть одно "но". Когда макрос уже выполнен и созданная книга открыта - все хорошо, но если ее закрыть и продолжить работу с исходным документом, вылетает ошибка и Excel закрывается. Как исправить - не могу понять.
' Функции для обращения к папке Мои документы
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (pidl As Long, ByVal pszPath As String) As Long
Private Const MAX_PATH = 260
Public Enum siCSIDL_VALUES
CSIDL_PERSONAL = &H5 ' Папка "Мои документы"
End Enum
Private Function dhTrimNull(strValue As String) As String
Dim intPos As Integer
intPos = InStr(strValue, vbNullChar)
Select Case intPos
Case 0
dhTrimNull = strValue
Case 1
dhTrimNull = ""
Case Else
dhTrimNull = Left$(strValue, intPos - 1)
End Select
End Function
Public Function SpecialFolderLocation(ByVal CSIDL As siCSIDL_VALUES) As String
Dim lngRet As Long
Dim strLocation As String
Dim pidl As Long
lngRet = SHGetSpecialFolderLocation(0, CSIDL, pidl)
strLocation = Space$(MAX_PATH)
lngRet = SHGetPathFromIDList(ByVal pidl, strLocation)
SpecialFolderLocation = dhTrimNull(strLocation)
End Function
Sub Создание_протокола()
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
i = ThisWorkbook.Name
Application.ScreenUpdating = False
Workbooks.Open Filename:= _
"C:\Шаблон.xlt" _
, Editable:=True
Sheets("Лист1").Select
Windows(i).Activate
' Копирование-вставка из исходного документа в шаблон
Range("A4:AI49").Select
Selection.Copy
Windows("Шаблон.xlt").Activate
Range("A4:AI49").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
Windows(i).Activate
Range("AL4:AN9").Select
Selection.Copy
Windows("Шаблон.xlt").Activate
Range("AL4:AN9").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
' Создание пути к файлу
strPath = SpecialFolderLocation(CSIDL_PERSONAL)
ControlPath = "\" & "Контроль"
ObjectPath = ControlPath & "\" & Range("AM5")
OrganizationPath = ObjectPath & "\" & Range("L52")
MaterialPath = OrganizationPath & "\" & "Материал"
DatePath = MaterialPath & "\" & Range("AM10")
ControlFolderName = strPath & ControlPath
ObjectFolderName = strPath & ObjectPath
OrganizationFolderName = strPath & OrganizationPath
MaterialFolderName = strPath & MaterialPath
DateFolderName = strPath & DatePath
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do Until oFSO.FolderExists(DateFolderName)
If oFSO.FolderExists(DateFolderName) = True Then
ChDir DateFolderName
Else
If oFSO.FolderExists(ControlFolderName) = False Then
MkDir ControlFolderName
Else
If oFSO.FolderExists(ObjectFolderName) = False Then
MkDir ObjectFolderName
Else
If oFSO.FolderExists(OrganizationFolderName) = False Then
MkDir OrganizationFolderName
Else
If oFSO.FolderExists(MaterialFolderName) = False Then
MkDir MaterialFolderName
Else
If oFSO.FolderExists(DateFolderName) = False Then
MkDir DateFolderName
Else
ChDir ControlFolderName
End If
End If
End If
End If
End If
End If
Loop
If oFSO.FolderExists(DateFolderName) = True Then
ChDir DateFolderName
End If
' Вывод диалогового окна Сохранить как... с уже введеным именем документа
Имя_для_Сохранения = [H18] & " " & [AE16]
On Error Resume Next
Set SH = Workbooks(Имя_для_Сохранения & ".xls")
If Not IsEmpty(SH) Then
Workbooks(Имя_для_Сохранения & ".xls").Close (True)
FName = Application.GetSaveAsFilename(InitialFileName:=Имя_для_Сохранения, _
FileFilter:="Excel Files (*.xls), *.xls", _
Title:=" Сохранение документа ")
Else
FName = Application.GetSaveAsFilename(InitialFileName:=Имя_для_Сохранения, _
FileFilter:="Excel Files (*.xls), *.xls", _
Title:="Сохранение документа")
End If
If VarType(FName) <> vbBoolean Then Workbooks("Шаблон.xlt").SaveAs FName
Windows("Шаблон.xlt").Close (False)
Application.ScreenUpdating = True
End Sub
