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

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
or if can, define delete pages create with modified worksheet code
 
Upvote 0
I think you can use this code :
VBA Code: 
Sub CopyPaste()
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
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
L = i - 1
Set ws = ShP
j = ShP.Index
Sheets(j + 1).Visible = True
Sheets(j + 1).Select
n = Int((L - Fr + 1) / 32) + 1
Sheets(j + 1).PageSetup.PrintArea = Sheets(j + 1).Range("A1:H" & n * 34 + 6).Address
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = False
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).ClearContents
DSheet.Select
Application.ScreenUpdating = True
End Sub
 
Upvote 0
maabadi said:
I think you can use this code :
VBA Code: 
Sub CopyPaste()
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
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
L = i - 1
Set ws = ShP
j = ShP.Index
Sheets(j + 1).Visible = True
Sheets(j + 1).Select
n = Int((L - Fr + 1) / 32) + 1
Sheets(j + 1).PageSetup.PrintArea = Sheets(j + 1).Range("A1:H" & n * 34 + 6).Address
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = False
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).ClearContents
DSheet.Select
Application.ScreenUpdating = True
End Sub
Click to expand...
this is not completely delete (the page not like this manner in photo i send below), i want something like delete shift cells up (and also delete center footer)
 

Attachments

  • image_2021-03-18_232028.png
    image_2021-03-18_232028.png
    5 KB · Views: 3
  • Screenshot 2021-03-18 232244.png
    Screenshot 2021-03-18 232244.png
    2.6 KB · Views: 3
Upvote 0
Unexpc said:
this is not completely delete (the page not like this manner in photo i send below), i want something like delete shift cells up (and also delete center footer)
Click to expand...
no need delete center footer because i remind when that delete, number of page not show after delete, just delete like shift cells up and after that like show image 1
 
Upvote 0
Try this full code:
VBA Code: 
Sub CopyPaste()
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
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
L = i - 1
Set ws = ShP
j = ShP.Index
Sheets(j + 1).Visible = True
Sheets(j + 1).Select
n = Int((L - Fr - 2) / 32) + 1
Sheets(j + 1).PageSetup.PrintArea = Sheets(j + 1).Range("A1:H" & n * 34 + 6).Address
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
'Sheets(j + 1).Visible = False
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
End Sub
 
Upvote 0
One thing I forgot:
Please remove ' at start of line :
VBA Code: 
'Sheets(j + 1).Visible = False
 
Upvote 0
maabadi said:
Try this full code:
VBA Code: 
Sub CopyPaste()
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
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
L = i - 1
Set ws = ShP
j = ShP.Index
Sheets(j + 1).Visible = True
Sheets(j + 1).Select
n = Int((L - Fr - 2) / 32) + 1
Sheets(j + 1).PageSetup.PrintArea = Sheets(j + 1).Range("A1:H" & n * 34 + 6).Address
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
'Sheets(j + 1).Visible = False
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
End Sub
Click to expand...
no delete function, even no page after 2 in print
 
Upvote 0
previous code is ok, data are deleting, only format cells like colored cells and border not deleted, that is causes i said shift delete cells up for example...
 
Upvote 0
Please Test it again. I test it on your Uploaded file and it works very well. this is screenshots before deleting and after deleting line with last code!!!!??
 

Attachments

  • 11111.jpg
    11111.jpg
    232 KB · Views: 4
  • 11112.jpg
    11112.jpg
    240.6 KB · Views: 4
  • 11113.jpg
    11113.jpg
    196.7 KB · Views: 4
  • 11114.jpg
    11114.jpg
    177.9 KB · Views: 4
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
72
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
101
NKUNZI
N
F
  • Solved
Copy paste from one Excel workbook to another with same sheet names and update dates in range
Replies
8
Views
515
Skiier89
S

Forum statistics

Threads
1,223,952
Messages
6,175,589
Members
452,653
Latest member
craigje92

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