'Кнопка Сформировать
Private Sub ButtonReport_Click()
Dim a(), i As Long, k As Long
'........................................ здесь все, что до строки  Firma = Me.ListBox1.Value
'    Firma = Me.ListBox1.Value

    With ListBox1
        ReDim a(1 To .ListCount)
        
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                k = k + 1: a0(k) = .List(i)
            End If
        Next i
    End With
    
    Call Report(a0, k)
    Unload Me
End Sub

Sub Report(a0(), k As Long)
Dim n As Long
'.......................
                If Reestr.Cells(i, 4) <= DateFinish Then
                    For n = 1 To k
                        If Reestr.Cells(i, 6) = a0(n) Then
                             .Cells(LR, 1) = Reestr.Cells(i, 1).Value
'.......................

With ListBox1
        ReDim a(1 To .ListCount)
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                k = k + 1: [b]a0(k) [/b]= .List(i)
            End If
        Next i
    End With

Sub Report(a0(), k As Long)
Dim n As Long
Dim i As Long, LastRow As Long, LR As Long

LR = 5 ' Указали, что первая свободная строка для нового отчёта будет =5
With Card 'Применительно ко второму листу
        LastRow = .Cells(Rows.Count, 1).End(xlUp).row 'Нашли последнюю строку на втором листе
        Range(.Cells(5, 1), .Cells(LastRow + 1, 4)).Clear 'Очистили диапазон отчета полностью
        .Cells(2, 2).ClearContents 'Очистили ЗНАЧЕНИЯ в шапке отчета
        .Cells(2, 2) = "Отчет с " & DateStart & " по " & DateFinish 'Заполнили заголовок отчета
        .Cells(3, 2) = "Карточка:  " & Firma
        LastRow = Cells(Rows.Count, 1).End(xlUp).row 'Нашли последнюю строку на первом листе
        For i = 3 To LastRow 'Начали цикл (на первом листе) со строки № 3 по последнюю
            If Reestr.Cells(i, 4) >= DateStart Then
                 If Reestr.Cells(i, 4) <= DateFinish Then
                    For n = 1 To k
                        If Reestr.Cells(i, 6) = a0(n) Then
                            .Cells(LR, 1) = Reestr.Cells(i, 1).Value
                            .Cells(LR, 2) = Reestr.Cells(i, 4).Value
                            .Cells(LR, 3) = Reestr.Cells(i, 6).Value
                            .Cells(LR, 4) = Reestr.Cells(i, 7).Value
                           LR = LR + 1 'Увеличили на единичку номер первой свободной строки отчета
                        End If
                  End If
            End If
                Next n
         Next i
        'Заполним подвал отчета
        .Cells(LR, 1) = "Итого:"
        .Cells(LR, 4) = Application.WorksheetFunction.Sum(Range(.Cells(5, 4), .Cells(LR - 1, 4))) 'Посчитали сумму отчета
        Range(.Cells(5, 1), .Cells(LR, 4)).Borders.LineStyle = xlContinuous 'Сделали обрамление ячеек
End With
    If LR = 5 Then MsgBox "По данными критериям данных не найдено!", 64, "Сообщение"
End Sub