Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как сделать что бы изменение формул в Шаблоне приводило к изменениям расчётов на всех КопияхШаблонаХХ
 
#1
10.06.2021 08:48:38
Здравствуйте, уважаемые специалисты.Создал сложную систему расчётов из трёх последовательно связанных Листов т.е. расчёты из Листа1 передаются для последующих расчётов на Лист2, затем итоги расчётов Листа2 служат отправными данными для расчётов на Листе3. Все 3 листа так же берут статичные данные с Листа Констант для своих расчётов. Используется множество ячеек типа Список, заданных в ДиспетчереИмён формул. Пока нет макросов или модулей из VisualBasic, но возможно далее понадобятся, пока можно обходиться без них. Назовём эту систему из трёх листов расчётов - шаблоном, для последующего копирования.

На основании данного Шаблона - требуется создать в этом же документе (или лучше разнести эти КопииШаблонаХХ по новосоздаваемым Файлам Эксель, не суть, просто очень много листов получается в одном файле) на данном этапе около 40 копий (по 3 Листа), в дальнейшем число копий может увеличиваться примерно до 60 или чуть более.
Задача - требуется создавать листы КопииШаблонаХХ таким образом, что бы свои ячейки с расчётами они проводили согласно формулам взятым из шаблона. Это нужно для того, что бы когда придётся изменить формулу в Шаблоне, добавить или удалить строку или столбец - все КопииШаблонаХХ подхватили произведённое изменение форматирования или изменение формулы и поменяли свои расчёты, согласно уникальным для каждого листа КопииШаблона ячейкам с ручным вводом цифровых значений, которые из шаблона не берутся, а задаются в этих ячейках на каждой КопииШаблона вручную.

В файле примера для наглядности упростил все формулы до тривиальных расчётов типа Цена-Количество-Итого и в качестве Шаблона задал всего 1 лист.
Помогите, пожалуйста, понять, какими средствами Эксель лучше всего произвести подобный перенос форматирования и формул заданных на листе Шаблона на множество листов КопийШаблонаХХ.
Изменено: vikttur - 10.06.2021 13:15:35
 
 
 
#2
10.06.2021 10:39:25
Макрос создаст копии из шаблона в ту же папку.
Если копии уже существуют, перенесёт всё, кроме констант, из шаблона в копию.
Код
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
 
 
 
Страницы: 1
Наверх