EXCELer.org

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:

www.rondebruin.nl/print.htm