Save from a template to XLS only visible sheets

[swieduwi]

I have a template (XLT) that has a lot of VB code that hides and unhide
sheets depending on the values in cells. once entry is complete I nee
to save the sheets that are visible to a workbook.xls
I have the code that saves the file, but how do I code the ability t
save only the sheets showing on the tabs. oh and not include the v
code aswell..

 

[swieduwi]

Here is my save file code, including the print and new site code.


Code
-------------------

Sub FileSave()
On Error Resume Next
Dim strFileName As String
Dim strDir As String
Dim strSite As String
Dim strSiteType As String
Dim strNewFile As String

strDir = "G:\CHCS\_MHS\TIMPO\VPN\SiteSpecificDocs\"
strSite = Sheets("Addressing").Range("I7").Value
strDirName = Sheets("Addressing").Range("D2").Value
strFileName = Sheets("Addressing").Range("D28").Value

If strSite = "f" Then
strSiteType = "_Air Force"
Else
End If

If strSite = "a" Then
strSiteType = "_Army"
Else
End If

If strSite = "n" Then
strSiteType = "_Navy"
Else
End If

If strSite = "m" Then
strSiteType = "_Navy"
End If

' Check for Site Directory
On Error Resume Next
MkDir strDir & strSiteType & "\" & strDirName
On Error GoTo 0

' Save file here
strNewFile = strDir & strSiteType & "\" & strDirName & "\" & strFileName & " VPN IP Address.XLS"

MsgBox "Saving File " & strNewFile, vbOKCancel = 1

ActiveWorkbook.SaveAs strNewFile, FileFormat:=xlNormal

End Sub

Sub PrintSite()
Dim response
Sheet1.PrintOut
response = MsgBox("Do you need another copy?", vbYesNo + vbQuestion, "Confirmation")
If response = vbNo Then
Call FillSiteList
Call NewSite
Else
End If
End Sub

Private Sub FillSiteList()
Dim rngAsnNumber As Range
Set rngAsnNumber = Range("Sites!A2:A1000")
For i = 1 To 1000
With rngAsnNumber
If .Cells(i, 1) = "" Then
.Cells(i, 1).Value = Sheet1.Range("J9").Value
.Cells(i, 2).Value = Sheet1.Range("O9").Value
.Cells(i, 3).Value = Sheet1.Range("D2").Value
.Cells(i, 4).Value = Sheet1.Range("D3").Value
.Cells(i, 5).Value = Sheet1.Range("D4").Value
.Cells(i, 6).Value = Sheet1.Range("D5").Value
.Cells(i, 7).Value = Sheet1.Range("D6").Value
.Cells(i, 8).Value = Sheet1.Range("D7").Value
.Cells(i, 9).Value = Sheet1.Range("D8").Value
.Cells(i, 10).Value = Sheet1.Range("D9").Value
.Cells(i, 11).Value = Sheet1.Range("S2").Value
.Cells(i, 12).Value = Sheet1.Range("S3").Value
.Cells(i, 13).Value = Sheet1.Range("H8").Value
.Cells(i, 14).Value = Sheet1.Range("H9").Value
Exit For
End If
End With
Next i
End Sub

Sub NewSite()
Dim rngAsnNumber As Range

Call FillSiteList
Call FileSave

Sheet1.Range("H8").Select
Set rngAsnNumber = Range("Sites!E2:E1000")
For i = 1 To 1000
If rngAsnNumber.Cells(i, 1) = "" Then
If Not IsNumeric(rngAsnNumber.Cells(i - 1, 1).Value) Then

Sheet1.Range("H8").Value = Sheets("Sites").Range("M65536").End(xlUp).Value - 1
Else
Sheet1.Range("H8").Value = rngAsnNumber.Cells(i - 1, 1).Value - 1
End If
Exit For
End If
Next i

End Sub

 

[bhofsetz]

I do a similar operation with my templates as well.

The way I do it is to copy all the desired sheets into a different
workbook and save that with a new file name. This eliminates the VB
code (unless it is attached to the particular worksheet being copied).
In my case I already know which sheets will be copied to the new
workbook. In your case you can loop through all the worksheets in the
active workbook and then only copy the visible worksheets.


Code:
--------------------
Sub SaveVisibleSheets()
Dim sh As Object
For Each sh In ThisWorkbook.Worksheets
If sh.Visible = True Then
sh.Copy After:=Workbooks("DestinationWorkbookName").Sheets(3)
End If
Next sh
End Sub

 

[swieduwi]

I am getting sub script out of range on this line...


Code

 

[bhofsetz]

substitue in the name of the workbook where you want the copied sheet
to be pasted.

I used "DestinationWorkbookName" as a generic intended for you t
replace with the actual name of the workbook where you want the copie
sheets. This needs to be an existing workbook which is currently open

 

[swieduwi]

Yea ,I figured that out, but It still gives me the erro

 

[bhofsetz]

Add the ' .xls ' extension to the workbook name in the quotes.
Also make sure the destination workbook has three sheets Re:
..sheets(3) or change that to .sheets(1)

sh.Copy After:=Workbooks("DestinationWorkbookName.xls").Sheets(1)

sorry for the confusion

HTH

 

[swieduwi]

Add the ' .xls ' extension to the workbook name in the quotes.
Also make sure the destination workbook has three sheets Re:
.sheets(3) or change that to .sheets(1)

sh.Copy After:=Workbooks("DestinationWorkbookName.xls").Sheets(1)

sorry for the confusion

HTH

I am still getting sub script out of range on this line...
I think it has to do with the number of visable sheets " .sheets(3)"
I tried to count first the amount of sheets, and still get error ?
How do I count only visable sheets ?

This may be it:

Code:
--------------------

Sub SaveVisibleSheets()
Dim sh As Object
Dim shcnt as Integer

shcnt = ActiveWorkbook.Sheets.Count

For Each sh In ThisWorkbook.Worksheets
If sh.Visible = True Then
sh.Copy After:=Workbooks("c:\test\WorkbookName.xls").Sheets(shcnt)
End If
Next sh
End Sub

 

[bhofsetz]

Just change the Sheets(3) to Sheets(1) [see my last post] because any
workbook has to have at least one visible worksheet.

Or you can have it added at the end by using Sheets(Sheets.Count) in
place of Sheets(3).

 

[swieduwi]

Just change the Sheets(3) to Sheets(1) [see my last post] because any
workbook has to have at least one visible worksheet.

Or you can have it added at the end by using Sheets(Sheets.Count) in
place of Sheets(3).

OK,
It does not mater if I put the (1) 'sheet count' as "1" or "3" I still
Get an error
*"sub script out of range "*

Add the ' .xls ' extension to the workbook name in the quotes.
Also make sure the destination workbook has three sheets Re:
.sheets(3) or change that to .sheets(1)

sh.Copy After:=Workbooks("DestinationWorkbookName.xls").Sheets(1)

sorry for the confusion

HTH

I can not test any farther until the error is gone. I can't get around
it

 

[bhofsetz]

Is your destination workbook open? It has to be open in order to copy
the sheets to it.

Also I would suggest using the

sh.Copy
After:=Workbooks("DestinationWorkbookName.xls").Sheets(Sheets.Count)

line instead of the .Sheets(1)

Either way should work but the one with Sheets.Count will always put
the copied sheet at the end.

I'm not sure if that is the cause of your sub script out or range error
but the only way I can get that bit of code to error for me is if the
destination workbook isn't open.

 

[swieduwi]

Is your destination workbook open? It has to be open in order to cop
the sheets to it.

No sheets exists at the destination, workbook will be created at sav
time with a name from a cell in the existing template.

Also I would suggest using the

sh.Cop
After:=Workbooks("DestinationWorkbookName.xls").Sheets(Sheets.Count)

line instead of the .Sheets(1)

Either way should work but the one with Sheets.Count will always pu
the copied sheet at the end.

I'm not sure if that is the cause of your sub script out or range erro
but the only way I can get that bit of code to error for me is if th
destination workbook isn't open.

I have tried the code with an open workbook and I still get an error
----------------------------------
| Run-Time error '9' |
| subscript out of range |
----------------------------------
Think of it like this, my template is a data entry screen, you enter I
address information into the fields, the application figures ou
subnetting, routing and calulates Binary, Hex and Dec information fo
trouble shooting networks. also creates all configs for VPN Device
Cisco Switches and Cisco Routers (Cut and paste commands) and create
drawings for documantation.

The user Clicks a Save Button and it Saves the Template workbook to
shared network drive location with the name of the site configured.

This data then is saved in a CSV File for the app to check to see i
future sites that will be configured do not conflict with past sites.

I hope this clears things up, I will try to post the workbook on m
website for download (800k) If you would like to see it.
The size issue is why I need to save the workbook with only the visibl
sheets because I have about 20 sheets total but only about 7 - 8 ar
visible depending on options selected

 

[bhofsetz]

You have to have an open workbook for the sheets to be copied to so have
the code create a new workbook with the desired name in the desired
path. Then copy all the visible sheets to that workbook. Then save.



Code:
--------------------
Sub SaveVisibleSheets()
Workbooks.Add
ActiveWorkbook.SaveAs "NewWorkbookName.xls" 'Change the SaveAs file
'name to reflect the directory and name you want for your file.
Dim sh As Object
For Each sh In ThisWorkbook.Worksheets
If sh.Visible = True Then
sh.Copy After:=Workbooks("NewWorkbookName.xls").Sheets(Sheets.Count)
'Change the NewWorkbookName.xls to whatever name you have saved the
'workbook as in the SaveAs line above.
End If
Next sh
ActiveWorkbook.Save 'This NewWorkbook will by default have Sheets1, 2 & 3
'so you can have the code delete those sheets before the final save.
End Sub
--------------------


I'm not sure why you are getting a | Run-Time Error 9 | | subscript
out of range | error if the destination workbook is open.
Try copying and pasting my code directly into a module and run it as is
to see if you still get the same error.

 

[swieduwi]

You have to have an open workbook for the sheets to be copied to so have
the code create a new workbook with the desired name in the desired
path. Then copy all the visible sheets to that workbook. Then save.

Ok I guess opening a new one will be ok.

I'm not sure why you are getting a | Run-Time Error 9 | | subscript out
of range | error if the destination workbook is open.
Try copying and pasting my code directly into a module and run it as is
to see if you still get the same error.

I tried pasting this code into a module and I still get the error.
I will post my worksheet tonight at home for download at
http://www.wieduwilt.us/excel

I just can not figure out what is going on, there could be a conflict
with the existing code.