Sub CopyPaste()
Dim ShP As Worksheet, SrRange As Range, Cell As Range, i 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
Application.ScreenUpdating = False
Set ShP = Worksheets("Sheet")
Set SrRange = Selection
Debug.Print SrRange.Address
For Each Cell In SrRange
If Cell.Interior.Color = 4697456 And Cell.Value <> "" Then
ShP.Range("A1").Value = Cell.Value
ElseIf Cell.Value <> "" Then
ShP.Range("B" & 3 + i).Value = Cell.Value
i = i + 1
End If
Next Cell
L = i
Set ws = ActiveSheet
j = ActiveSheet.Index
Sheets(j + 1).Visible = True
Sheets(j + 1).Select
Debug.Print ws.Range("A1").Value
For i = 1 To 30840
If 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 + 1) / 2 _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
Sheets(j + 1).Visible = True
Sheets(j).Select
ShP.Range("A1").ClearContents
ShP.Range("B3:B" & L + 2 ).ClearContents
Application.ScreenUpdating = True
End Sub