Save each worksheet with formatting in loop - excel

Question

I have a template file and 4 source documents that I use to fill the template. For each row in sheet2, I create a new blank template and fill it out, resulting in somewhere between 10-100 files. I want to save these in a loop, but having issues with Excel force closing on me. This is my code so far, recycled from a different project.
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>" & folderName
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\ThisProject\csvOutput\" & folderName
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " 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 & Chr(92) & 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 ```

Answer 1

The code below worked for me: not sure exactly where the problem might vbe with your posted code, but within your With blocks not everything is scope to the block using a leading .
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:\Users\Username\OneDrive - CompanyName\Documents\Projects\" & _
"ThisProject\csvOutput\" & Format(Date, "ddmmyyyy") & "\"
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " 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 & 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