Sub сохранение_новый()

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Application.ThisWorkbook.Path & "\" & CStr(Range("A4")) & "\" & CStr(Range("B4")) & "\" & Range("AC3") & ".xlsx", FileFormat:=51
 
Application.DisplayAlerts = True

End Sub

Option Explicit
Const sWinRarAppPath As String = "C:\Program Files\WinRAR\WinRAR.exe"

Sub архивация()
 If FolderToRAR("ThisWorkbook.Path") Then
        MsgBox "Папка успешно заархивирована!"
    End If
End Sub 

Function FolderToRAR(sPath As String)
    Dim sArhiveName As String
    Dim sWinRarApp As String
    sPath = ThisWorkbook.Path
    sWinRarApp = sWinRarAppPath & " A -ep "
    sArhiveName = sPath & Format(Now, "DD - MM - YYYY") & ".rar"
    FolderToRAR = Shell(sWinRarApp & " """ & sArhiveName & """ """ & sPath \ приложения \ архивы & """ ", vbHide)
End Function

t = Sheets("буфер").Cells(Rows.Count, 3).End(xlUp).Row
Sheets("буфер").Range(("A2:D" & t), ("F2:G" & t), ("J2:J" & t), ("L2:L" & t)).SpecialCells(xlCellTypeVisible).Copy
Sheets("отчет").Select
Sheets("отчет").Cells(3, 1).PasteSpecial Paste:=xlPasteValues

Private Sub UserForm2_Initialize()

Application.ScreenUpdating = False
Dim stRow As Long
Dim strName As String
Dim t As Integer
Dim Wbb As Workbook
strName = ThisWorkbook.Path & "\приложения\база\движение.xlsb"
Set Wbb = Workbooks.Open(strName)
Me.ListBox1.Clear
stRow = Wbb.Sheets("движение").Cells(Rows.Count, 5).End(xlUp).Row
With Wbb.Sheets("движение")
    .Cells(2, 5).AutoFilter Field:=5, Criteria1:=Me.UserForm2.TextBox1
    .Select
End With
Cells = SpecialCells(xlVisible)
 t = 0
    For r = 2 To stRow
    Me.UserForm2.ListBox1.AddItem ""
    Me.UserForm2.ListBox1.List(t, 0) = Wbb.Sheets("движение").Cells(r, 2).Value
    Me.UserForm2.ListBox1.List(t, 1) = Wbb.Sheets("движение").Cells(r, 8).Value
    Me.UserForm2.ListBox1.List(t, 2) = Wbb.Sheets("движение").Cells(r, 9).Value
    Me.UserForm2.ListBox1.List(t, 3) = Wbb.Sheets("движение").Cells(r, 10).Value
    Me.UserForm2.ListBox1.List(t, 4) = Wbb.Sheets("движение").Cells(r, 11).Value
    Me.UserForm2.ListBox1.List(t, 5) = Wbb.Sheets("движение").Cells(r, 15).Value
    Me.UserForm2.ListBox1.List(t, 6) = Wbb.Sheets("движение").Cells(r, 16).Value
    Me.UserForm2.ListBox1.List(t, 7) = Wbb.Sheets("движение").Cells(r, 17).Value
    
     t = t + 1
    Next
    Windows("движение").Close False
    Application.ScreenUpdating = True
End Sub

Sub СохранитьЛистыВФайл1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim New_Wb As Workbook
    Set New_Wb = Workbooks.Add
    ThisWorkbook.Sheets(Array("сводная", "выводрем", "выводсм")).Copy
   New_Wb.Activate
New_Wb.SaveAs Filename:=Application.ThisWorkbook.Path & "\" & CStr(Range("L1")) & "\" & CStr(Range("M1")) & "\" & CStr(Range("N1")) & "\" & Range("O1") & ".xlsx", FileFormat:=51
ActiveSheet.Buttons.Delete
For Each cell In Sheets(Array("сводная", "выводрем", "выводсм")).UsedRange.Cells
   cell.Formula = cell.Value
Next cell

New_Wb.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Выполнено!"
End Sub

Private Sub UserForm_Activate()
Dim LastRow As Range
Dim strFName As String
Dim x As Integer
    
strFName = ThisWorkbook.Path & "\расход"
Workbooks.Open strFName
    Me.ListBox1.Clear
  
  LastRow = Workbooks("расход").Sheets("прайс").Cells(Rows.Count, 5).End(xlUp).Row
        x = 0
        For i = 3 To LastRow
            .ListBox1.AddItem ""
            .ListBox1.List(x, 0) = strFName.Sheets("прайс").Cells(i, 5).Value
            .ListBox1.List(x, 1) = strFName.Sheets("прайс").Cells(i, 6).Value
            .ListBox1.List(x, 2) = strFName.Sheets("прайс").Cells(i, 18).Value
            .ListBox1.List(x, 3) = strFName.Sheets("прайс").Cells(i, 19).Value
            .ListBox1.List(x, 4) = strFName.Sheets("прайс").Cells(i, 20).Value
            x = x + 1
        Next
        Windows("расход").Close
End Sub

Sub Заполнить1()
Dim BegPeriod As Date
Dim EndPeriod As Date
Dim iFoundRng As Range

BegPeriod = Worksheets("отчетрасход").Range("F1")
EndPeriod = Worksheets("отчетрасход").Range("I1")
Set JournalSht = ThisWorkbook.Worksheets("орасход")
Application.ScreenUpdating = False

Range("A3:I200").Select
Selection.Font.Bold = False
Selection.EntireRow.Hidden = False
Selection.ClearContents
Range("A3").Select

With JournalSht
Set iFoundRng = .Columns(1).Find(What:=BegPeriod, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not iFoundRng Is Nothing Then
  
For i = 3 To 40
If .Cells(iFoundRng.Row + i - 3, 1) <= EndPeriod Then
Cells(i, 1) = .Cells(iFoundRng.Row + i - 3, 1) 'дата
Cells(i, 2) = .Cells(iFoundRng.Row + i - 3, 2) '№ счета
Cells(i, 4) = .Cells(iFoundRng.Row + i - 3, 4) 'ответственный
Cells(i, 5) = .Cells(iFoundRng.Row + i - 3, 5) 'техника
Cells(i, 6) = .Cells(iFoundRng.Row + i - 3, 6) '№ техники
Cells(i, 8) = .Cells(iFoundRng.Row + i - 3, 9) 'сумма

Else
End If
Next
End If
End With
f = Cells(Rows.Count, 1).End(xlUp).Row
Range("A3:I" & f).Select
 ActiveWorkbook.Worksheets("отчетрасход").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("отчетрасход").Sort.SortFields.Add Key:=Range( _
        "D3:D" & f), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
 ActiveWorkbook.Worksheets("отчетрасход").Sort.SortFields.Add Key:=Range( _
        "E3:E" & f), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
      With ActiveWorkbook.Worksheets("отчетрасход").Sort
        .SetRange Range("A3:I" & f)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
 Range("B2:I" & f).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("отчетрасход!Criteria"), Unique:=True
 Range("I3:I" & f).FormulaR1C1 = "=SUMIFS(C[-1],C[-5],RC[-5],C[-4],RC[-4])"
 Range("I3:I" & f + 2).FormulaR1C1 = "=AGGREGATE(9,5,R3C9:R[-2]C9)"
 
Application.ScreenUpdating = True
End Sub

Sub промежуточные_итоги()

 Dim s As Long
 s = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1:E" & s).Select
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2, 3, 4, 5) _
        , Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    ActiveWindow.SmallScroll Down:=-9
    Range("A2").Select
End Sub

Sub вставка_второй_таблицы()

    ActiveSheet.Outline.ShowLevels RowLevels:=2
    Range("A1:E36").Select     ' указаны конкретные ячейки, а нужно те, что получатся в таблице
    Selection.Copy
    ActiveWindow.SmallScroll Down:=3
    Range("A40").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-3
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "затраты"
    Range("A4").Select
End Sub

Sub форматирование()

ActiveSheet.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
  
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A2").Select
End Sub

Sub анализ_ремонты()

    Dim sFolder As String, sFiles As String 
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""

        Workbooks.Open sFolder & sFiles
      
        ActiveWorkbook.Sheets("Лист1").Range("A1:D1").Copy
       Workbooks("анализ оплата").Sheets("оплремонты").Cells((Sheets("оплремонты").(Rows.Count, 1).End(xlUp).Row) + 1, 2).PasteSpecial Paste:=xlPasteValues
       ActiveWorkbook.Sheets("Лист1").Close False
       sFiles = Dir
            
    Loop
 
    Application.ScreenUpdating = True
End Sub

Workbooks("анализ оплата").Sheets("оплремонты").Cells((Sheets("оплремонты").(Rows.Count, 1).End(xlUp).Row) + 1, 2).PasteSpecial Paste:=xlPasteValues
       ActiveWorkbook.Sheets("Лист1").Close False
       sFiles = Dir