Здравствуйте, уважаемые специалисты.Создал сложную систему расчётов из трёх последовательно связанных Листов т.е. расчёты из Листа1 передаются для последующих расчётов на Лист2, затем итоги расчётов Листа2 служат отправными данными для расчётов на Листе3. Все 3 листа так же берут статичные данные с Листа Констант для своих расчётов. Используется множество ячеек типа Список, заданных в ДиспетчереИмён формул. Пока нет макросов или модулей из VisualBasic, но возможно далее понадобятся, пока можно обходиться без них. Назовём эту систему из трёх листов расчётов - шаблоном, для последующего копирования.
На основании данного Шаблона - требуется создать в этом же документе (или лучше разнести эти КопииШаблонаХХ по новосоздаваемым Файлам Эксель, не суть, просто очень много листов получается в одном файле) на данном этапе около 40 копий (по 3 Листа), в дальнейшем число копий может увеличиваться примерно до 60 или чуть более. Задача - требуется создавать листы КопииШаблонаХХ таким образом, что бы свои ячейки с расчётами они проводили согласно формулам взятым из шаблона. Это нужно для того, что бы когда придётся изменить формулу в Шаблоне, добавить или удалить строку или столбец - все КопииШаблонаХХ подхватили произведённое изменение форматирования или изменение формулы и поменяли свои расчёты, согласно уникальным для каждого листа КопииШаблона ячейкам с ручным вводом цифровых значений, которые из шаблона не берутся, а задаются в этих ячейках на каждой КопииШаблона вручную.
В файле примера для наглядности упростил все формулы до тривиальных расчётов типа Цена-Количество-Итого и в качестве Шаблона задал всего 1 лист. Помогите, пожалуйста, понять, какими средствами Эксель лучше всего произвести подобный перенос форматирования и формул заданных на листе Шаблона на множество листов КопийШаблонаХХ.
Макрос создаст копии из шаблона в ту же папку. Если копии уже существуют, перенесёт всё, кроме констант, из шаблона в копию.
Код
Option Explicit
Public fso As Object
Sub CopyTemplate()
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
ThisWorkbook.Save
Dim sPath As String
sPath = ThisWorkbook.Path & "\"
Dim sNameBase As String
sNameBase = ThisWorkbook.Name
If Mid(sNameBase, 4, 1) = "_" Then sNameBase = Mid(sNameBase, 5)
Dim sFullBase As String
sFullBase = sPath & sNameBase
Dim sFullTemp As String
sFullTemp = sPath & "tmp_" & sNameBase
CloseAndDeleteFile sFullTemp
ThisWorkbook.SaveAs Filename:=sFullTemp, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Dim wbBase As Workbook
Dim wbCopy As Workbook
Dim sFullCopy As String
Dim i As Integer
For i = 1 To 40
sFullCopy = sPath & Format(i, "000") & "_" & sNameBase
Application.StatusBar = fso.GetFileName(sFullCopy)
Set wbBase = Workbooks.Open(sFullBase, False, True)
If fso.FileExists(sFullCopy) Then
Set wbCopy = Workbooks.Open(sFullCopy, False, True)
CopyToTemplate wbCopy, wbBase
Set wbCopy = Nothing
End If
wbBase.Sheets(1).Cells(1, 1).Value = "Копия " & i
CloseAndDeleteFile sFullCopy
wbBase.SaveAs Filename:=sFullCopy, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wbBase.Close False
Set wbBase = Nothing
Application.StatusBar = False
Next
CloseAndDeleteFile sFullBase
ThisWorkbook.SaveAs Filename:=sFullBase, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
If fso.FileExists(sFullTemp) Then fso.DeleteFile (sFullTemp)
Application.Calculation = Application_Calculation
Application.ScreenUpdating = True
End Sub
Sub CopyToTemplate(wbCopy As Workbook, wbBase As Workbook)
Dim shCopy As Worksheet
Dim shBase As Worksheet
Dim rCopy As Range
For Each shCopy In wbCopy.Worksheets
On Error Resume Next
Set shBase = wbBase.Sheets(shCopy.Name)
On Error GoTo 0
If shBase Is Nothing Then
Dim i As Long
i = shCopy.Index
If i = 1 Then
shCopy.Copy Before:=wbBase.Sheets(1)
Else
i = i - 1
If i > wbBase.Sheets.Count Then i = wbBase.Sheets.Count
shCopy.Copy After:=wbBase.Sheets(i)
End If
Else
On Error Resume Next
Set rCopy = shCopy.Cells.SpecialCells(xlCellTypeConstants, 23)
On Error GoTo 0
If Not rCopy Is Nothing Then
Dim rArea As Range
Dim arr As Variant
For Each rArea In rCopy.Areas
arr = rArea
Application.EnableEvents = False
shBase.Range(rArea.Address(0, 0)) = arr
Application.EnableEvents = True
Next
Set rCopy = Nothing
End If
shBase.UsedRange.Calculate
Set shBase = Nothing
End If
Next
End Sub
Sub CloseAndDeleteFile(sFull As String)
On Error Resume Next
Workbooks(fso.GetFileName(sFull)).Close False
On Error GoTo 0
If fso.FileExists(sFull) Then fso.DeleteFile (sFull)
End Sub