PDA

View Full Version : Values and formats of only visible sheets and ranges copied to a new book



mduff
09-10-2007, 04:17 PM
Hi all,

I found this code in the Kb (Thanks to Justinlabenne for posting it) to copy Specific sheets to a new workbook but I need add a little twist to it.
What I need if for the code to only copy Visible sheets and Columns and rows (not copy any worksheet that is hidden ( i am using VB Very hidden) and not to copy any rows or columns that are hidden).

Basically what I need is the Values and formats of only visible sheets and ranges copied to a new book


http://www.vbaexpress.com/kb/getarticle.php?kb_id=359 (http://www.vbaexpress.com/kb/getarticle.php?kb_id=359)



Option Explicit

Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet

If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub

With Application
.ScreenUpdating = False

' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error Goto ErrCatcher
Sheets(Array("Copy Me", "Copy Me2")).Copy
On Error Goto 0

' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select

' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm

' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False

.ScreenUpdating = True
End With
Exit Sub

ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub




thanks

L@ja
09-11-2007, 05:08 AM
hali,
the following will cos you copy only the visible sheets:

Dim wc()
ReDim wc(0 To 0)
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
If wc(UBound(wc)) = "" Then
wc(0) = ws.Name
Else
ReDim Preserve wc(0 To UBound(wc) + 1)
wc(UBound(wc)) = ws.Name
End If
End If
Next ws
Sheets(wc).Copy


the visible rows and cols need others
regards