Sub DataCopy()
Dim foldername As String
Dim Source As Workbook
Dim Target As Workbook
Dim counter As Long
Dim strFile As String
Dim fd As FileDialog
Dim i As Long, m As Long, n As Long

Set Target = ActiveWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
    .Title = "Выберите папку с отчётами для сохранения."
    If .Show = -1 Then
        strFolder = .SelectedItems(1) & "\"
    Else
        MsgBox "Вы не выбрали папку."
        Exit Sub
    End If
End With
strFile = Dir$(strFolder & "*.xlsx")
counter = 0
While strFile <> ""
    Set Source = Workbooks.Open(strFolder & strFile)
    With Target.Sheets(1).Range("A1")
        i = .CurrentRegion.Rows.Count
        For m = 1 To Source.Sheets(1).Range("A4").CurrentRegion.Rows.Count - 1
            For n = 0 To Source.Sheets(1).Range("A4").CurrentRegion.Columns.Count - 1
                .Offset(i, n) = Source.Sheets(1).Range("A4").Offset(m, n)
            Next n
            i = i + 1
        Next m
    End With
    counter = counter + 1
    Source.Close xlDoNotSaveChanges
    strFile = Dir$()
Wend
MsgBox ("Завершено и обработано " & counter & " файлов")
End Sub

Sub Создание_сводной_итоги_сделка()

Dim rngData As Range, PTCache As PivotCache, PT As PivotTable
Call Удалить_другие_листы

Set rngData = ThisWorkbook.Worksheets("РМ администратора").Range("a3").CurrentRegion
Set PTCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, rngData.Address)
Set PT = PTCache.CreatePivotTable(Worksheets.Add.[a4], "Итоги")
ActiveSheet.Name = "Текущие итоги"

With ActiveSheet.PivotTables("Итоги").PivotFields("Данные способа обращения")
        .Orientation = xlRowField.....
End Sub

Sub Duplicate_Rows()
    Dim cell As Range
 
    Set cell = Range("F2")      'первая ячейка в столбце с кол-вом билетов
    Do While Not IsEmpty(cell)
        If cell > 1 Then
            cell.Offset(1, 0).Resize(cell.Value - 1, 1).EntireRow.Insert    'вставляем N пустых строк
            cell.Resize(cell.Value, 1).EntireRow.FillDown                   'заполняем вниз из первых ячеек
        End If
        Set cell = cell.Offset(cell.Value, 0)
        
    Loop
End Sub