Copy selection range and paste in a specific sheet

U

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
496
Office Version
  1. 2019
Platform
  1. Windows
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...
 
Sort by date Sort by votes
Unexpc said:
i mean for C4 copy format cell from 8 and for G4 copy format cell from 10
Click to expand...
If I understand you want to format column C (at Print Sheet) based First Cell Selected at Column B at Source sheet. AND
format column G (at Print Sheet) based Last Cell Selected at Column B at Source sheet.
Is this Correct?
 
Upvote 0

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Try this:
VBA Code: 
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
ActiveSheet.Range("B" & Fr).Copy  
ShP.Range("C4").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
ActiveSheet.Range("B" & Fr).Copy  
ShP.Range("C4").PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Range("B" & Lr).Copy  
ShP.Range("G4").PasteSpecial Paste:=xlPasteFormats
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
 
Upvote 0
maabadi said:
Try this:
VBA Code: 
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
ActiveSheet.Range("B" & Fr).Copy 
ShP.Range("C4").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
ActiveSheet.Range("B" & Fr).Copy 
ShP.Range("C4").PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Range("B" & Lr).Copy 
ShP.Range("G4").PasteSpecial Paste:=xlPasteFormats
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
Click to expand...
i test but not work
 
Upvote 0
mabaadi something is wrong, please print test customer from Row 4 to 6 and see print pdf, not correct replaced format cell
example file : Book T=Ts.rar
 
Upvote 0
Sorry. change ShP to Sheets(J + 1) at these lines (red parts):
Rich (BB code): 
ActiveSheet.Range("B" & Fr).Copy 
ShP.Range("C4").PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Range("B" & Lr).Copy 
ShP.Range("G4").PasteSpecial Paste:=xlPasteFormats
 
Upvote 0
maabadi said:
Sorry. change ShP to Sheets(J + 1) at these lines (red parts):
Rich (BB code): 
ActiveSheet.Range("B" & Fr).Copy
ShP.Range("C4").PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Range("B" & Lr).Copy
ShP.Range("G4").PasteSpecial Paste:=xlPasteFormats
Click to expand...
i change that, and in print change background of this two cell, not work
 

Attachments

  • Print تست(1)_001.png
    Print تست(1)_001.png
    14.9 KB · Views: 6
Upvote 0
Change that lines to :
Rich (BB code): 
DSheet.Range("B" & Fr).Copy
Sheets(J + 1).Range("C4").PasteSpecial Paste:=xlPasteFormats
DSheet.Range("B" & Lr).Copy
Sheets(J + 1).Range("G4").PasteSpecial Paste:=xlPasteFormats
 
Upvote 0
maabadi said:
Change that lines to :
Rich (BB code): 
DSheet.Range("B" & Fr).Copy
Sheets(J + 1).Range("C4").PasteSpecial Paste:=xlPasteFormats
DSheet.Range("B" & Lr).Copy
Sheets(J + 1).Range("G4").PasteSpecial Paste:=xlPasteFormats
Click to expand...
about copy format cell is work correctly i think, front of paste what word should write that just paste format cell not all formats like background color and font size and otherthing...
 
Upvote 0
How about:
VBA Code: 
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, NF As String
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
ActiveSheet.Range("B" & Fr).Copy
ShP.Range("C4").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
With Sheets(J + 1)
 DSheet.Range("B" & Fr).Copy
.Range("C4").PasteSpecial Paste:=xlPasteFormats
 DSheet.Range("B" & Lr).Copy
.Range("G4").PasteSpecial Paste:=xlPasteFormats
.Range("C4:G4").Interior.Color = .Range("D4").Interior.Color
.Range("C4:G4").Font.Size = .Range("D4").Font.Size
.Range("C4:G4").Font.Name = .Range("D4").Font.Name
.PageSetup.PrintArea = .Range("A1:H" & N * 34 + 6).Address
End With
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

Z
  • Question Question
Vba - create new sheet and copy date into it.
Replies
1
Views
69
zerofeng
Z
J
  • Question Question
Macro to assign to print button with specific criteria
2
Replies
11
Views
663
Micron
M
J
  • Question Question
Using Sheets().Select in a Worksheet_Activate() macro
2
Replies
10
Views
448
jdun
J
N
  • Question Question
VBA to add title from formula to a save as name
Replies
0
Views
100
NKUNZI
N
F
  • Solved
Copy paste from one Excel workbook to another with same sheet names and update dates in range
Replies
8
Views
514
Skiier89
S

Forum statistics

Threads
1,223,948
Messages
6,175,566
Members
452,652
Latest member
eduedu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top