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
and please upload code without invisible Print, because it have delay after run code and print
 
Upvote 0

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
and anyway combine this code with your solution code? this is when 2 page is fill, copy page 2 and paste in page 3 and next pages like this
(doing with number sequence of cells, this is your before solution code too :) )
VBA Code: 
If Target.Count = 1 And Target.Column = 2 And Target.Row >= 67 Then
        If (Target.Row - 35) Mod 32 = 0 Then
            If Target.Value <> "" Then
                lRow = (((Target.Row - 35) * 34) / 32) + 7
                With ThisWorkbook.Sheets("Print")
                    .Range("A" & lRow & ":H" & lRow + 33).Copy .Range("A" & lRow + 34)
                    Sheets("Print").Visible = False
                    Application.ScreenUpdating = True
                    Application.EnableEvents = True
                End With
            End If
 
Upvote 0
1. Only select data not green Cells At column A, Macro automatically Take green Cells from Column A.
2. Because of my Previous code is worksheet Change event Code, It runs automatically when Data changed at target column & don't need to Combine.
 
Upvote 0
maabadi said:
1. Only select data not green Cells At column A, Macro automatically Take green Cells from Column A.
2. Because of my Previous code is worksheet Change event Code, It runs automatically when Data changed at target column & don't need to Combine.
Click to expand...
1.yes, but wrong take
2.but not copy/paste page 2 in 3 and next pages like this i tested and still available 2 pages while data more than 2 page
 
Upvote 0
Try this:
VBA Code: 
Sub CopyPaste()
Dim ShP As Worksheet, SrRange As Range, i As Long, k As Long, L As Long, CL As Range
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 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 Lr
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
ShP.Range("A1").Value = Cells(i, FC).Value
k = i + 2
ElseIf Cells(i, FC + 1).Value <> "" Then
Range(ShP.Cells(3 + i - k, 2), ShP.Cells(3 + i - k, 2 + 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
For i = 1 To 30840
If Sheets(j + 1).Cells(34 * i + 8, 1).Value <> "" Then
n = i + 1
Else
GoTo Printing
End If
Next i
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print" & j / 2 _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = False
Sheets(j).Select
ShP.Range("A1:A2").ClearContents
'Range(ShP.Cells(3, 2), ShP.Cells(L, 2 + LC - FC)).ClearContents
On Error Resume Next
For Each CL In Range(ShP.Cells(3, 2), ShP.Cells(L, 2 + LC - FC))
        If CL.MergeCells Then
        CL.MergeArea.ClearContents
        Else
        CL.ClearContents
        End If
    Next CL
Application.ScreenUpdating = True
End Sub
 
Upvote 0
maabadi said:
Try this:
VBA Code: 
Sub CopyPaste()
Dim ShP As Worksheet, SrRange As Range, i As Long, k As Long, L As Long, CL As Range
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 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 Lr
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
ShP.Range("A1").Value = Cells(i, FC).Value
k = i + 2
ElseIf Cells(i, FC + 1).Value <> "" Then
Range(ShP.Cells(3 + i - k, 2), ShP.Cells(3 + i - k, 2 + 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
For i = 1 To 30840
If Sheets(j + 1).Cells(34 * i + 8, 1).Value <> "" Then
n = i + 1
Else
GoTo Printing
End If
Next i
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print" & j / 2 _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = False
Sheets(j).Select
ShP.Range("A1:A2").ClearContents
'Range(ShP.Cells(3, 2), ShP.Cells(L, 2 + LC - FC)).ClearContents
On Error Resume Next
For Each CL In Range(ShP.Cells(3, 2), ShP.Cells(L, 2 + LC - FC))
        If CL.MergeCells Then
        CL.MergeArea.ClearContents
        Else
        CL.ClearContents
        End If
    Next CL
Application.ScreenUpdating = True
End Sub
Click to expand...
no, it has a big bug after first customer and not doing copy/paste correct order
and why have delay after save print? screen freeze on loading, if going to Sheet and invisible Print cause this, please broke this function thank you
and that is find last green cell in column A before first select in column B?
 
Last edited:
Upvote 0
that is because of clear content of merging Cells.
1. one thing which cells in your Pasted range is merged to I define clear them separately.
for others try this:
VBA Code: 
Sub CopyPaste()
Dim ShP 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 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 Lr
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
ShP.Range("A1").Value = Cells(i, FC).Value
k = i + 2
GoTo Resum
End If
Next i
Resum:
For i = Fr To Lr
If Cells(i, FC + 1).Value <> "" Then
Range(ShP.Cells(3 + i - k, 2), ShP.Cells(3 + i - k, 2 + 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
For i = 1 To 30840
If Sheets(j + 1).Cells(34 * i + 8, 1).Value <> "" Then
n = i + 1
Else
GoTo Printing
End If
Next i
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print" & j / 2 _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = False
Sheets(j).Select
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, 2), ShP.Cells(L, 1 + LC - FC)).ClearContents
Application.ScreenUpdating = True
End Sub
 
Upvote 0
And About Not Printing More than 2 Pages. I check, Your Print Sheet don't have formula at page 3 & more. IF you copy Page 2 to Page 3 & ... then Results appears & Printing.
 
Upvote 0
maabadi said:
that is because of clear content of merging Cells.
1. one thing which cells in your Pasted range is merged to I define clear them separately.
for others try this:
VBA Code: 
Sub CopyPaste()
Dim ShP 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 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 Lr
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
ShP.Range("A1").Value = Cells(i, FC).Value
k = i + 2
GoTo Resum
End If
Next i
Resum:
For i = Fr To Lr
If Cells(i, FC + 1).Value <> "" Then
Range(ShP.Cells(3 + i - k, 2), ShP.Cells(3 + i - k, 2 + 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
For i = 1 To 30840
If Sheets(j + 1).Cells(34 * i + 8, 1).Value <> "" Then
n = i + 1
Else
GoTo Printing
End If
Next i
Printing: ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Print" & j / 2 _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = False
Sheets(j).Select
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, 2), ShP.Cells(L, 1 + LC - FC)).ClearContents
Application.ScreenUpdating = True
End Sub
Click to expand...
1.A1&A2 Merged
Disordered order data copy/pasting, but delay fix and show #N/A in column F
 
Upvote 0
For #N/A at Headers Column F you should check all of your data at Column A is Numbers Not Text.
For Correct Printing Pages Try this:
VBA Code: 
Sub CopyPaste()
Dim ShP 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 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 Lr
If Cells(i, FC).Interior.Color = 4697456 And Cells(i, FC).Value <> "" Then
ShP.Range("A1").Value = Cells(i, FC).Value
k = i + 2
GoTo Resum
End If
Next i
Resum:
For i = Fr To Lr
If Cells(i, FC + 1).Value <> "" Then
Range(ShP.Cells(3 + i - k, 2), ShP.Cells(3 + i - k, 2 + 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" & j / 2 _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
   :=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = False
Sheets(j).Select
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, 2), ShP.Cells(L, 1 + LC - FC)).ClearContents
Application.ScreenUpdating = True
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,573
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