Sub Auto_Print()

    Dim lRowsCount As Long
    Dim lFirstRow As Long
    Dim lNextRow As Long
    
    lRowsCount = Application.WorksheetFunction.Subtotal(3, Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)))
    With ActiveSheet.AutoFilter.Range
    lFirstRow = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible).Row
    End With
    lNextRow = Range("A" & lFirstRow + 1 & ":A65536").SpecialCells(xlCellTypeVisible).Row
    Rows(lFirstRow).Copy
    
    For i = 1 To lRowsCount
    Workbooks.Open ("D:\Documents\Mac\Form.xlsx")
    Windows("Form.xlsx").Activate
    Sheets("Лист1").Select
    Rows(2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Лист2").Select
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Windows("Пример.xlsm").Activate
    Rows(lNextRow).Copy
    lNextRow = Range("A" & lNextRow + 1 & ":A65536").SpecialCells(xlCellTypeVisible).Row
    Next i    
       
End Sub