Hi,
My code loops through worksheets from 12 onwards and saves each as a separate file.
I've used a For...Next loop to do this - this is the same one I've used in other macros and it works fine.
However on this occasion, it won't stop at the final sheet; it tries to do another loop and therefore crashes.
There must be something obvious - I just can't see it!
I've copied all the code below in case something earlier on is breaking it.
Thanks for any help.
Regards.
Mark
Sub SaveCCFiles()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim FilePath As String
Dim FileName As String
Dim CCLookup As String
Dim Period As String
Dim FolderCheck As String
Dim Location As String
Dim Response2 As String
Dim CreateFolder
Dim CheckCell As Range
Dim StartCheck As Range
Dim EndCheck As Range
Dim CheckMessage As String
Dim z As Integer
'======================================================================================
'Checks for #N/As again
Set StartCheck = Worksheets("data").Range("a4")
Set EndCheck = Worksheets("data").Range("d65534").End(xlUp)
For Each CheckCell In Range(StartCheck, EndCheck)
If WorksheetFunction.IsNA(CheckCell) Then
CheckMessage = "Cell " & CheckCell.Address & " shows an error. Please correct."
MsgBox CheckMessage
Range(CheckCell.Address).Activate
Exit Sub
If CheckCell.Text = "#N/A" Then
CheckMessage = "Cell " & CheckCell.Address & " shows an error. Please correct."
MsgBox CheckMessage
Range(CheckCell.Address).Activate
Exit Sub
End If
End If
Next
'============================================================================================
With Application
.ScreenUpdating = True
.EnableEvents = False
End With
'Ask where to save the files
'================================================================================================
Do
FilePath = InputBox("Where do you want to save the files? Last character must be '\'!", "File Location...", "c:\users\mark\Files\")
If Right(FilePath, 1) <> "\" Then MsgBox "You haven't included the '\' at the end!"
Loop Until Right(FilePath, 1) = "\"
Response2 = MsgBox("The new files will now be created in " & FilePath _
& vbCrLf & "Click 'Cancel' if you do not wish to proceed.", vbOKCancel, "Information ...")
If Response2 = vbCancel Then Exit Sub
If Dir(FilePath, vbDirectory) = "" Then CreateFolder = MsgBox("The folder does not exist; do you wish to create it?", vbYesNo)
If CreateFolder = vbYes Then
MkDir FilePath
Else
MsgBox "The action was terminated." _
& vbCrLf & "" _
& vbCrLf & "The file was NOT created."
End If
'Go through all sheets from Sheet 12 and save - THIS IS WHERE IT GOES WRONG!
'=========================================================================
For z = 12 To Sheets.Count
Sheets(z).Select
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
FileName = ActiveSheet.name & " - From " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs FilePath & FileName & ".xls": FileFormatNum = -4143
.Close SaveChanges:=False
End With
Next
'Ask whether or not to delete the sheets in source file
'=====================================================
Range("A1").Select
Dim Quest As String
Dim Ans
Quest = InputBox("CC Files have been created. Do you want to delete the original worksheets now?", "Delete worksheets?", vbYes)
Select Case Ans
Case vbNo
Exit Sub
Case vbYes
For Each wks In Worksheets
If (wks.name <> "Data" And wks.name <> "Summary" And wks.name <> "Instructions" And _
wks.name <> "MI" And wks.name <> "Sheet4" And wks.name <> "Sheet5" And wks.name <> "Sheet6" And _
wks.name <> "Data Orig" And wks.name <> "SGL" And wks.name <> "Grade" And wks.name <> "Rates") Then wks.Delete
Next wks
End Select
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
My code loops through worksheets from 12 onwards and saves each as a separate file.
I've used a For...Next loop to do this - this is the same one I've used in other macros and it works fine.
However on this occasion, it won't stop at the final sheet; it tries to do another loop and therefore crashes.
There must be something obvious - I just can't see it!
I've copied all the code below in case something earlier on is breaking it.
Thanks for any help.
Regards.
Mark
Sub SaveCCFiles()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim FilePath As String
Dim FileName As String
Dim CCLookup As String
Dim Period As String
Dim FolderCheck As String
Dim Location As String
Dim Response2 As String
Dim CreateFolder
Dim CheckCell As Range
Dim StartCheck As Range
Dim EndCheck As Range
Dim CheckMessage As String
Dim z As Integer
'======================================================================================
'Checks for #N/As again
Set StartCheck = Worksheets("data").Range("a4")
Set EndCheck = Worksheets("data").Range("d65534").End(xlUp)
For Each CheckCell In Range(StartCheck, EndCheck)
If WorksheetFunction.IsNA(CheckCell) Then
CheckMessage = "Cell " & CheckCell.Address & " shows an error. Please correct."
MsgBox CheckMessage
Range(CheckCell.Address).Activate
Exit Sub
If CheckCell.Text = "#N/A" Then
CheckMessage = "Cell " & CheckCell.Address & " shows an error. Please correct."
MsgBox CheckMessage
Range(CheckCell.Address).Activate
Exit Sub
End If
End If
Next
'============================================================================================
With Application
.ScreenUpdating = True
.EnableEvents = False
End With
'Ask where to save the files
'================================================================================================
Do
FilePath = InputBox("Where do you want to save the files? Last character must be '\'!", "File Location...", "c:\users\mark\Files\")
If Right(FilePath, 1) <> "\" Then MsgBox "You haven't included the '\' at the end!"
Loop Until Right(FilePath, 1) = "\"
Response2 = MsgBox("The new files will now be created in " & FilePath _
& vbCrLf & "Click 'Cancel' if you do not wish to proceed.", vbOKCancel, "Information ...")
If Response2 = vbCancel Then Exit Sub
If Dir(FilePath, vbDirectory) = "" Then CreateFolder = MsgBox("The folder does not exist; do you wish to create it?", vbYesNo)
If CreateFolder = vbYes Then
MkDir FilePath
Else
MsgBox "The action was terminated." _
& vbCrLf & "" _
& vbCrLf & "The file was NOT created."
End If
'Go through all sheets from Sheet 12 and save - THIS IS WHERE IT GOES WRONG!
'=========================================================================
For z = 12 To Sheets.Count
Sheets(z).Select
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
FileName = ActiveSheet.name & " - From " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs FilePath & FileName & ".xls": FileFormatNum = -4143
.Close SaveChanges:=False
End With
Next
'Ask whether or not to delete the sheets in source file
'=====================================================
Range("A1").Select
Dim Quest As String
Dim Ans
Quest = InputBox("CC Files have been created. Do you want to delete the original worksheets now?", "Delete worksheets?", vbYes)
Select Case Ans
Case vbNo
Exit Sub
Case vbYes
For Each wks In Worksheets
If (wks.name <> "Data" And wks.name <> "Summary" And wks.name <> "Instructions" And _
wks.name <> "MI" And wks.name <> "Sheet4" And wks.name <> "Sheet5" And wks.name <> "Sheet6" And _
wks.name <> "Data Orig" And wks.name <> "SGL" And wks.name <> "Grade" And wks.name <> "Rates") Then wks.Delete
Next wks
End Select
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub