以循环格式保存每个工作表

Question

我有一个模板文件和4个源文档，我用它们来填充模板。对于sheet2中的每一行，我创建一个新的空白模板并将其填充，从而产生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>" & folderName
fp = "C:UsersUsernameOneDrive - CompanyNameDocumentsProjectsThisProjectcsvOutput" & 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

下面的代码为我工作:不确定问题可能与您发布的代码在哪里，但在您的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" & _
"ThisProjectcsvOutput" & 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