Copy selection range and paste in a specific sheet

[Unexpc]

Hi guys
i want when i select a range, after that with run a macro, doing this 3 steps
Paste in a sheet that named Sheet from cell A3
after that print from a sheet that named Print
after that clear contents from A3 until rows of sheet that named Sheet be ended...

 

[Unexpc]

1. Why page setup for print added to Sheet Worksheet and Not to Print Worksheet?

i don't understand exactly

2. I didn't see code for Print area at this file. where you add it?

in module

 

[Unexpc]

1. Why page setup for print added to Sheet Worksheet and Not to Print Worksheet?

if i understand, because when copy from main data, paste in specific range,in Page 1 from Print start in Row 8 and end in Row 39,Row 1:8 for some data Row 40 for SUM of this page,
and in Page 2 start in Row 42 and end in Row 73, Row 41 for texts and Row 74 is for SUM
all this cells linked to Sheet that show data from that
generally, give (copy) data in main sheet data (Work for example), paste in Sheet, and Shows in Print and export to pdf from Print

 

[Unexpc]

and a thing i remember to say, please if can, the code gives just format cells of Column B in main data sheet that copy from that (first source data) and paste this format cells in column A (just cells that linked to Sheet A8:A39, A42:A73,...) from Print

 

[maabadi]

see page 2 in print pdf

1. What is problem in Sheet2?

the code gives just format cells of Column B in main data sheet

2. Code do this now!? what you want exactly? please describe it with detail

 

[Unexpc]

1. What is problem in Sheet2?

not print some rows from main and + SUM row at the end and page number too, this is happened with new code and values, maybe problem with formula, with previous format is use number and may work with numbers, i don't know but not correctly print...

2. Code do this now!? what you want exactly? please describe it with detail

no, not for now, i asked new if can, Detail is i say better, i have specific rows for show data (this rows 8:39 for page 1, 42:73 for page 2 and next page like this pattern), for this range, i want give format cells of source sheet that copy from that (in example file, Work is source sheet that i want copy from that
*(this code you write for all sheets that have same columns and row, it means all sheet have this column and row can copy from that for print, because of this i think written this in module, but i want this function, not change just for a sheet please)
however when copy for example from Work, copy format cells of Column B from this sheet and paste this format cells to specific rows from Print i said

 

[maabadi]

Change 32 at this line to 34

Sheets(J + 1).PageSetup.PrintArea = Sheets(J + 1).Range("A1:H" & N * 32 + 6).Address

for format you want also color , font or ... . please tell exactly or only number format ( as Date or ....)
for me number formating work correctly. but you want font, color and ... please describe it.

 

[Unexpc]

Sheets(J + 1).PageSetup.PrintArea = Sheets(J + 1).Range("A1:H" & N * 32 + 6).Address

yes, correct!

please tell exactly or only number format ( as Date or ....)
for me number formating work correctly. but you want font, color and ... please describe it.

the format of i want replaced is changeable, stable format is : 00"/"00"/"00
this for date i used, but some items have two date with two different days or two different months that i use : 00"/"00"/"00"،"00 and 00"/"00"،"00"/"00"،"00

 

[maabadi]

Try this but maybe code run slower:

Sub PageForPrint()
Dim ShP As Worksheet, DSheet As Worksheet, SrRange As Range, i As Long, K As Long, L As Long
Dim MyRange As Range, ws As Worksheet, Lastrow As Long, N As Long, J As Long, P As String
Dim PrintArea As String, FC As Long, LC As Long, Fr As Long, Lr As Long, Y As Long
Application.ScreenUpdating = False
Set ShP = Worksheets("Sheet")
Set DSheet = ActiveSheet
Set SrRange = Selection
FC = SrRange.Column
LC = SrRange.Columns.Count
Fr = SrRange.Row
Lr = SrRange.Rows.Count + Fr - 1
Y = Fr - SrRange.Rows.Count
K = Fr + Application.WorksheetFunction.CountBlank(Range(Cells(Fr, FC), Cells(Lr, FC)))
For i = Fr To 1 Step -1
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
ShP.Range("A1").Value = Cells(i, FC).Value
If Fr = i Then
K = Fr + 2
Else
K = Fr
End If
GoTo Resum
End If
Next i
Resum:
For i = Fr To Lr
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
If i > Fr Then
ShP.Cells(3 + i - K, 1).Value = Cells(i, FC).Value
End If
ElseIf Cells(i, FC + 1).Value <> "" Then
Range(ShP.Cells(3 + i - K, 2), ShP.Cells(3 + i - K, 1 + LC - FC)).Value = Range(Cells(i, FC + 1), Cells(i, LC)).Value
End If
Next i
ActiveSheet.Range("B" & Fr & ":B" & Lr).Copy
ShP.Range("B3:B" & 2 + i - K).PasteSpecial Paste:=xlPasteFormats
L = i - 1
Set ws = ShP
J = ShP.Index
Sheets(J + 1).Visible = True
Sheets(J + 1).Select
N = Int((L - Fr - 0) / 32) + 1
For i = 1 To N
If SrRange.Rows.Count > i * 32 Then
Sheets(J).Range("B" & Fr + (i - 1) * 32 & ":B" & Fr + i * 32 - 1).Copy
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & i * 34 + 5).PasteSpecial Paste:=xlPasteFormats
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & i * 34 + 5).Font.Size = 11
Else
Sheets(J).Range("B" & Fr + (i - 1) * 32 & ":B" & Fr + (i - 1) * 32 + SrRange.Rows.Count - (i - 1) * 32).Copy
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & (i - 1) * 34 + 8 + SrRange.Rows.Count - (i - 1) * 32).PasteSpecial Paste:=xlPasteFormats
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & (i - 1) * 34 + 8 + SrRange.Rows.Count - (i - 1) * 32).Font.Size = 11
End If
Next i
Sheets(J + 1).Range("A3:G10").EntireColumn.AutoFit
For i = 2 To 7
With Sheets(J + 1).Cells(4, i)
    For J = 1 To 3
        .ColumnWidth = 60 / .Width * .ColumnWidth
    Next J
End With
Next i
Sheets(J + 1).PageSetup.PrintArea = Sheets(J + 1).Range("A1:H" & N * 34 + 6).Address
Debug.Print Err.Number
Resum3:
On Error Resume Next
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value & P _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
  
If Err.Number <> 0 Then GoTo ErrorHandler

Sheets(J + 1).Visible = True
ShP.Range("A1:A2").ClearContents
On Error Resume Next
Range(ShP.Cells(3, 2), ShP.Cells(L, 1 + LC - FC)).MergeArea.ClearContents
Range(ShP.Cells(3, 1), ShP.Cells(L, 1 + LC - FC)).ClearContents
If N > 2 Then Sheets(J + 1).Range("A75:H" & N * 34 + 10).EntireRow.Delete
DSheet.Select
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
If P = "" Then
P = "(" & 1 & ")"
Else
P = "(" & Mid(P, 2, 1) + 1 & ")"
End If
Err.Number = 0
GoTo Resum3
End Sub

 

[Unexpc]

Try this but maybe code run slower:

Sub PageForPrint()
Dim ShP As Worksheet, DSheet As Worksheet, SrRange As Range, i As Long, K As Long, L As Long
Dim MyRange As Range, ws As Worksheet, Lastrow As Long, N As Long, J As Long, P As String
Dim PrintArea As String, FC As Long, LC As Long, Fr As Long, Lr As Long, Y As Long
Application.ScreenUpdating = False
Set ShP = Worksheets("Sheet")
Set DSheet = ActiveSheet
Set SrRange = Selection
FC = SrRange.Column
LC = SrRange.Columns.Count
Fr = SrRange.Row
Lr = SrRange.Rows.Count + Fr - 1
Y = Fr - SrRange.Rows.Count
K = Fr + Application.WorksheetFunction.CountBlank(Range(Cells(Fr, FC), Cells(Lr, FC)))
For i = Fr To 1 Step -1
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
ShP.Range("A1").Value = Cells(i, FC).Value
If Fr = i Then
K = Fr + 2
Else
K = Fr
End If
GoTo Resum
End If
Next i
Resum:
For i = Fr To Lr
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
If i > Fr Then
ShP.Cells(3 + i - K, 1).Value = Cells(i, FC).Value
End If
ElseIf Cells(i, FC + 1).Value <> "" Then
Range(ShP.Cells(3 + i - K, 2), ShP.Cells(3 + i - K, 1 + LC - FC)).Value = Range(Cells(i, FC + 1), Cells(i, LC)).Value
End If
Next i
ActiveSheet.Range("B" & Fr & ":B" & Lr).Copy
ShP.Range("B3:B" & 2 + i - K).PasteSpecial Paste:=xlPasteFormats
L = i - 1
Set ws = ShP
J = ShP.Index
Sheets(J + 1).Visible = True
Sheets(J + 1).Select
N = Int((L - Fr - 0) / 32) + 1
For i = 1 To N
If SrRange.Rows.Count > i * 32 Then
Sheets(J).Range("B" & Fr + (i - 1) * 32 & ":B" & Fr + i * 32 - 1).Copy
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & i * 34 + 5).PasteSpecial Paste:=xlPasteFormats
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & i * 34 + 5).Font.Size = 11
Else
Sheets(J).Range("B" & Fr + (i - 1) * 32 & ":B" & Fr + (i - 1) * 32 + SrRange.Rows.Count - (i - 1) * 32).Copy
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & (i - 1) * 34 + 8 + SrRange.Rows.Count - (i - 1) * 32).PasteSpecial Paste:=xlPasteFormats
Sheets(J + 1).Range("A" & (i - 1) * 34 + 8 & ":A" & (i - 1) * 34 + 8 + SrRange.Rows.Count - (i - 1) * 32).Font.Size = 11
End If
Next i
Sheets(J + 1).Range("A3:G10").EntireColumn.AutoFit
For i = 2 To 7
With Sheets(J + 1).Cells(4, i)
    For J = 1 To 3
        .ColumnWidth = 60 / .Width * .ColumnWidth
    Next J
End With
Next i
Sheets(J + 1).PageSetup.PrintArea = Sheets(J + 1).Range("A1:H" & N * 34 + 6).Address
Debug.Print Err.Number
Resum3:
On Error Resume Next
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value & P _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
 
If Err.Number <> 0 Then GoTo ErrorHandler

Sheets(J + 1).Visible = True
ShP.Range("A1:A2").ClearContents
On Error Resume Next
Range(ShP.Cells(3, 2), ShP.Cells(L, 1 + LC - FC)).MergeArea.ClearContents
Range(ShP.Cells(3, 1), ShP.Cells(L, 1 + LC - FC)).ClearContents
If N > 2 Then Sheets(J + 1).Range("A75:H" & N * 34 + 10).EntireRow.Delete
DSheet.Select
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
If P = "" Then
P = "(" & 1 & ")"
Else
P = "(" & Mid(P, 2, 1) + 1 & ")"
End If
Err.Number = 0
GoTo Resum3
End Sub

i test but not work, the format cell is stayed on i define for Print not changed (i define format cell for Print with this 00"/"00"/"00 but not copy from source sheet (Work) for different format cells for some date)

 

[maabadi]

But I test and work for me. please upload your example file.