View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
keepITcool keepITcool is offline
external usenet poster
 
Posts: 2,253
Default copy printarea from more than 3 sheet & save in new book.

****al,

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


"****al" wrote:

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.


****al