Блог

У меня есть файл шаблона и 4 исходных документа, которые я использую для заполнения шаблона. Для каждой строки листа 2 я создаю новый пустой шаблон и заполняю его, в результате чего получается где-то между 10-100 файлами. Я хочу сохранить их в цикле, но у меня возникли проблемы с принудительным закрытием Excel. До сих пор это мой код, переработанный из другого проекта.

 
    Dim w As Long, wb As Workbook
    Dim fp As String, fn As String
    Dim folderName As String
    Dim fsoFSO

    On Error GoTo bm_Safe_Exit
    'Application.ScreenUpdating = False   'stop screen flashing
    Application.DisplayAlerts = False    'stop confirmation alerts

    'start with a reference to ThisWorkbook
    With ThisWorkbook

    folderName = Format(Date, "ddmmyyyy")

    'set path to save
    'fp = "<PATH HERE>" amp; folderName
    fp = "C:UsersUsernameOneDrive - CompanyNameDocumentsProjectsThisProjectcsvOutput" amp; folderName


    Set fsoFSO = CreateObject("Scripting.FileSystemObject")
    If fsoFSO.FolderExists(fp) Then
        MsgBox "FOLDER - " amp; fp amp; " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
        Exit Sub
    Else
        fsoFSO.CreateFolder (fp)
    End If

        'cycle through each of the worksheets
        For w = 6 To Worksheets.Count
            With Worksheets(w)
                .Copy
                'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
                With ActiveWorkbook
                    fn = .Worksheets(1).Name

                Cells.Select
                Selection.SpecialCells(xlCellTypeVisible).Copy
                Worksheets.Add after:=Sheets(Sheets.Count)
                Range("A1").Select
                ActiveSheet.Paste
                Worksheets(1).Delete
                Worksheets(1).Name = fn

                    .SaveAs Filename:=fp amp; Chr(92) amp; fn, FileFormat:=51
                    .Close savechanges:=False   '<~~ already saved in line above
                End With
            End With
        Next w
    End With

bm_Safe_Exit:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub ```
 

Приведенный ниже код сработал для меня: не уверен, где именно может возникнуть проблема с вашим опубликованным кодом, но в ваших With блоках не все доступно для блока с использованием ведущего .

 Sub Test()

    Dim w As Long, wb As Workbook, wbNew As Workbook
    Dim fp As String, fn As String
    Dim fsoFSO

    On Error GoTo bm_Safe_Exit
    Set wb = ThisWorkbook

    fp = "C:UsersUsernameOneDrive - CompanyNameDocumentsProjects" amp; _
         "ThisProjectcsvOutput" amp; Format(Date, "ddmmyyyy") amp; ""
    
    Set fsoFSO = CreateObject("Scripting.FileSystemObject")
    If fsoFSO.FolderExists(fp) Then
        MsgBox "FOLDER - " amp; fp amp; " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
        Exit Sub
    Else
        fsoFSO.CreateFolder fp
    End If

    'cycle through each of the worksheets
    For w = 6 To wb.Worksheets.Count
        
        'explicitly create a new single-sheet workbook as the destination
        Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet)
        wb.Worksheets(w).Copy before:=wbNew.Sheets(1)
        DeleteSheet wbNew.Sheets(2)
        
        With wbNew
            fn = .Worksheets(1).Name
            .Worksheets.Add after:=.Worksheets(.Worksheets.Count)
            .Worksheets(1).Cells.SpecialCells(xlCellTypeVisible).Copy _
                                Destination:=.Worksheets(2).Range("A1")
            
            DeleteSheet .Worksheets(1)
            
            .Worksheets(1).Name = fn
            .SaveAs Filename:=fp amp; fn, FileFormat:=51
            .Close savechanges:=False   '<~~ already saved in line above
        End With
    Next w
    Exit Sub
    
bm_Safe_Exit:
    MsgBox Err.Description

End Sub

'utility sub
Sub DeleteSheet(ws As Worksheet)
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End Sub