EXCELer Tudo sobre EXCEL em Português
Se pretendermos obter uma impressão proveniente de Ranges descontínuos, sendo que um deles é proveniente de uma filtragem, podemos experimentar a seguinte peça de código, adaptando, para cada necessidade:
‘—————————————————————————————
‘ Módulo : Imprime
‘ Autor : JORGEROD
‘ Data : 24-09-2011
‘ Propósito : Imprimir vários Ranges descontinuos, um deles proveniente de uma filtragem
‘—————————————————————————————
Sub Imprime()
Dim Num As String
Dim Choice As String
Dim Destrange As Range
Dim Smallrng As Range
Dim Newsh As Worksheet
Dim Ash As Worksheet
Dim Lr As Long
Application.ScreenUpdating = False
Num = InputBox(Prompt:="Digite o número correspondente ao que pretende imprimir:", Title:="Situação Tributária")
If Num = "" Then
Exit Sub
Else
Set Ash = ActiveSheet
Set Newsh = Worksheets.Add
Ash.Select
Lr = 1
Choice = MsgBox(Prompt:="Pretende Imprimir?", Buttons:=vbYesNo, Title:="ATENÇÃO!!")
If Choice = vbNo Then
Application.DisplayAlerts = False
Newsh.Delete
Application.DisplayAlerts = True
Exit Sub
Else
Range("A6:K12").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:=Num
For Each Smallrng In Ash.Range("B2:K12,B14:C18").Areas
Smallrng.Copy
Set Destrange = Newsh.Cells(Lr, 1)
Destrange.PasteSpecial xlPasteValues
Destrange.PasteSpecial xlPasteFormats
Lr = Lr + Smallrng.Rows.Count
Next Smallrng
Newsh.Columns.AutoFit
Newsh.PageSetup.Orientation = xlLandscape
Newsh.PrintOut
Application.DisplayAlerts = False
Newsh.Delete
Application.DisplayAlerts = True
Selection.AutoFilter Field:=1
Selection.AutoFilter
End If
End If
Application.ScreenUpdating = True
End Sub
Parte do código apresentado tem créditos para Ron de Bruin (MVP Excel). Pode ser visto em:
