copy printarea from more than 3 sheet & save in new book.

[Shital]

code is given below which is working for copy printarea
and paste in new workbook with which ever is name
cell "C9" with paste as a value.
but is this copy only sheet1 printarea i want to copy
more than one sheet printarea. I want to copy user
printarea from sheet1, sheet2 & sheet3 and save into new
workbook with which eaver is name in sheet1 cell "C9".

any Help.

Sub testme01()

Dim newWks As Worksheet
Dim myRng As Range
Dim wks As Worksheet
Dim myPrintAddress As String

Set wks = ActiveSheet

myPrintAddress = wks.PageSetup.PrintArea

If myPrintAddress = "" Then
MsgBox "Please set a PrintArea"
Exit Sub
End If

Set newWks = Workbooks.Add(1).Worksheets(1)

wks.Range(myPrintAddress).Copy
'or you could use a built in range name:
'wks.Range("Print_area").Copy

With newWks.Range("a1")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
'new in xl2k?
'.PasteSpecial Paste:=xlPasteColumnWidths
End With

With newWks
'range C9 in original worksheet
.Parent.SaveAs FileName:=wks.Range("C9").Value
& " .xls"
'range c9 in the new worksheet
'.Parent.SaveAs Filename:=.Range("C9").Value
& " .xls"
.Parent.Close savechanges:=False
End With

End Sub

Shital

 

[keepitcool]

Shital,

Try like:


Sub CopyPA()
Dim wbS As Workbook
Dim wbT As Workbook
Dim w As Worksheet
Dim s As Variant
Dim a As Variant

Set wbS = ActiveWorkbook 'Alternative ThisWorkbook?
a = Array("sheet1", "sheet2", "sheet3")

'Verify PrintAreas
On Error Resume Next
For Each w In wbS.Worksheets(a)
If w.Names("Print_Area") Is Nothing Then s = s & w.Name & vbNewLine
Next
On Error GoTo 0

If Not IsEmpty(s) Then
MsgBox "PrintArea not set in " & vbNewLine & s
Exit Sub
End If

'Create book & sync sheetnames
Set wbT = Workbooks.Add(xlWBATWorksheet)
wbT.Sheets(1).Name = a(0)
For s = 1 To UBound(a)
Set w = wbT.Worksheets.Add(after:=Sheets(Sheets.Count))
w.Name = a(s)
Next

'Store Values in Target
For Each w In wbT.Worksheets
With Range(wbS.Names(w.Name & "!print_area").RefersTo)
.Value = wbS.Names(w.Name & "!print_area").RefersToRange.Value
End With
Next

'Save & Close
wbT.Close True, wbS.Sheets(1).Range("c9").Text

End Sub


keepITcool

< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >