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
maabadi said:
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!!!!??
Click to expand...
Yes, delete is working right, i delete all code and test it again and this is do it correct, but still print 2 pages
 
Last edited:
Upvote 0

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Unexpc said:
Yes, delete is working right, i delete all code and test it again and this is do it correct, but still print 2 pages
Click to expand...
i change line of clear content and entire delete code of previous your code, am i do correct?
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).EntireRow.Delete
DSheet.Select
Application.ScreenUpdating = True
End Sub
 
Upvote 0
and another problem show :( but you can do it :)
when i print a customer and save in document and i print again that customer, code going to execute mode and break, i think that is cause for same name, anyway duplicate or rename with plus (1) or anything like this that not show this error?
 
Upvote 0
Unexpc said:
, but still print 2 pages
Click to expand...
What means? with test file until row 34, this code print only page one, then until row 74 print page 2 and ...

Unexpc said:
i change line of clear content and entire delete code of previous your code, am i do correct?
Click to expand...
Also Change Line of defining n to this:
VBA Code: 
n = Int((L - Fr - 2) / 32) + 1

Unexpc said:
when i print a customer and save in document and i print again that customer, code going to execute mode and break,
Click to expand...
you should close pdf file after see it or if you don't want to see pdf file after created change code to this

OpenAfterPublish:=True TO OpenAfterPublish:=False

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
On Error Resume Next
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=False
Sheets(j + 1).Visible = False
ShP.Range("A1:A2").ClearContents
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
 
Upvote 0
Also Add at start of code :
VBA Code: 
Application.DisplayAlerts = False

AND at the end:
VBA Code: 
Application.DisplayAlerts = True
 
Upvote 0
maabadi said:
What means? with test file until row 34, this code print only page one, then until row 74 print page 2 and ...


Also Change Line of defining n to this:
VBA Code: 
n = Int((L - Fr - 2) / 32) + 1


you should close pdf file after see it or if you don't want to see pdf file after created change code to this

OpenAfterPublish:=True TO OpenAfterPublish:=False

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
On Error Resume Next
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print " & ShP.Range("A1").Value _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=False
Sheets(j + 1).Visible = False
ShP.Range("A1:A2").ClearContents
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
Click to expand...
when i change n definition that is just print 2 pages not 3, i think that is problem, this n definition is correct : n = Int((L - Fr + 1) / 32) + 1
and about duplicate, i test it and you are right, cause of this open pdf file
another thing, application display alerts, what is this doing?
 
Upvote 0
Unexpc said:
another thing, application display alerts, what is this doing?
Click to expand...

Prevent from showing & allowing alert windows
AND I think you don't need it here.
AND Test n at Both situation when your last row at print page filled to find correct definition. for me at your tested file this is OK:
VBA Code: 
n = Int((L - Fr - 2) / 32) + 1
Because of Two rows added For Selecting First customer name at Data Sheet.
 
Upvote 0
maabadi said:
Prevent from showing & allowing alert windows
AND I think you don't need it here.
AND Test n at Both situation when your last row at print page filled to find correct definition. for me at your tested file this is OK:
VBA Code: 
n = Int((L - Fr - 2) / 32) + 1
Because of Two rows added For Selecting First customer name at Data Sheet.
Click to expand...
Yes, if select name rows with data, this definition is right, so THANK YOU FOR HARD WORKING AND ANSWER QUESTIONS, YOU ARE LIKE ALWAYS PROFFESIONAL
 
Upvote 0
sorry, this is it came to my mind now, can you add a code that find out when pdf file open with same customer name (it means for first time create a print and open pdf file and for second time print again) make a pdf with different name for example Customer A (1) or like this and code not break or going execute mode, sorry again
 
Upvote 0
If you see error test deleting this line:
VBA Code: 
Range(ShP.Cells(3, 2), ShP.Cells(L, 1 + LC - FC)).MergeArea.ClearContents
try this:
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, 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
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
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 = 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
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
71
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,949
Messages
6,175,581
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