MrExcel Publishing
Your One Stop for Excel Tips & Solutions

Copy Sheets to a New Workbook based on Cell Contents


Posted by Nathan on September 13, 2001 9:49 AM

I've got a workbook with 10 sheets. I am running a macro to save off the main sheet. There are formulas on the other sheets referencing the main one. Each of the other sheets has a total list. I want the main sheet, and any sheet with something on the total line to be copied to a new book. Here's the code I have right now:

Private Sub SAVE_LUdlc1d6_Click()

SheetsInNewWorkbook = 1

' This makes sure that the macro button is not selected
Range("G1").Select

' This will copy the applicable sheet to a new book
Sheets("Cost summary").Select
Sheets("Cost summary").Copy

' This takes the value in G1 and makes it the default title of the new sheet
Dim strSaveAsFile As String
strSaveAsFile = Application.GetSaveAsFilename(Range("G1").Text, "Excel Workbook (*.xls), *.xls")
If strSaveAsFile <> "False" Then
ActiveWorkbook.SaveAs strSaveAsFile, xlWorkbookNormal
End If

Button_Click_Exit:
Exit Sub

Button_Click_Error:
Select Case Err.Number
Case 1004
Resume Button_Click_Exit
Case Else
MsgBox Err.Number & " " & Err.Description
End Select

On Error GoTo Button_Click_Error


' The follow sets of six IF statements will check all the
' information sheets in the workbook to see if there is a
' total on that sheet. If a total is found, then that
' sheet will be copied to the new workbook.

Windows("LUdlc1d6.xls").Activate
Sheets("Misc").Select
If Range("F20") <> 0 Then
Windows(strSaveAsFile).Activate
Sheets("Misc").Copy
End If

Windows("LUdlc1d6.xls").Activate
Sheets("DS1-fed RDT (768 wired)").Select
If Range("E65") <> 0 Then
Windows(strSaveAsFile).Activate
Sheets("DS1-fed RDT (768 wired)").Copy
End If

Windows("LUdlc1d6.xls").Activate
Sheets("DS1-fed HDT").Select
If Range("E60") <> 0 Then
Windows(strSaveAsFile).Activate
Sheets("DS1-fed HDT").Copy
End If

Windows("LUdlc1d6.xls").Activate
Sheets("FiberReach NB only").Select
If Range("F35") <> 0 Then
Windows(strSaveAsFile).Activate
Sheets("FiberReach NB only").Copy
End If

Windows("LUdlc1d6.xls").Activate
Sheets("FiberReach WB only").Select
If Range("F41") <> 0 Then
Windows(strSaveAsFile).Activate
Sheets("FiberReach WB only").Copy
End If

Windows("LUdlc1d6.xls").Activate
Sheets("Upgrade to 4.6").Select
If Range("F17") <> 0 Then
Windows(strSaveAsFile).Activate
Sheets("Upgrade to 4.6").Copy
End If

End Sub


Posted by Henry Root on September 13, 2001 6:40 PM

' This will copy the applicable sheet to a new book Sheets("Cost summary").Select Sheets("Cost summary").Copy


Try this :-

Private Sub XSAVE_LUdlc1d6_Click()
ActiveWorkbook.SaveAs Filename:=Range("G1")
Application.DisplayAlerts = False
If Sheets("1").Range("F20") = 0 Then
Sheets("1").Delete
End If
If Sheets("2").Range("E65") = 0 Then
Sheets("2").Delete
End If
If Sheets("3").Range("E60") = 0 Then
Sheets("3").Delete
End If
If Sheets("4").Range("F35") = 0 Then
Sheets("4").Delete
End If
If Sheets("5").Range("F41") = 0 Then
Sheets("5").Delete
End If
If Sheets("6").Range("F17") = 0 Then
Sheets("6").Delete
End If
Application.DisplayAlerts = True
End Sub


Posted by Henry Root on September 13, 2001 6:44 PM

Or more concisely .......


Private Sub XSAVE_LUdlc1d6_Click()
ActiveWorkbook.SaveAs Filename:=Range("G1")
Application.DisplayAlerts = False
If Sheets("1").Range("F20") = 0 Then Sheets("1").Delete
If Sheets("2").Range("E65") = 0 Then Sheets("2").Delete
If Sheets("3").Range("E60") = 0 Then Sheets("3").Delete
If Sheets("4").Range("F35") = 0 Then Sheets("4").Delete
If Sheets("5").Range("F41") = 0 Then Sheets("5").Delete
If Sheets("6").Range("F17") = 0 Then Sheets("6").Delete
Application.DisplayAlerts = True
End Sub

Posted by Henry Root on September 13, 2001 6:48 PM

Note ....


Substitute Sheets("1"),Sheets("2"), etc. with your sheet names