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
