Private Sub TextBox1_Change()
Sheets("БДП").Range("G2").Value = TextBox1.Value
End Sub

Sub сохранение_новый()
t = Application.ThisWorkbook.Path
t = StrReverse(Mid(StrReverse(t), InStr(1, StrReverse(t), "\") + 1))
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=t & "\папки\" & CStr(Range("A4")) & "\" & CStr(Range("B4")) & "\" & Range("AC3") & ".xlsb"
Selection.Replace What:="[*]", Replacement:=""
ActiveSheet.Buttons.Delete
Application.DisplayAlerts = True
End Sub

Sub очистка()
Dim TBL As ListObject
Set TBL = ActiveSheet.ListObjects("ремонты")
ActiveSheet.ListObjects("ремонты").ListColumns(1).DataBodyRange.Select
  If TBL.ListRows.Count > 1 Then
  TBL.DataBodyRange.Delete
  End If
End Sub

Sub удаление_в_архив()
'
'

'Application.ScreenUpdating = False
    ActiveSheet.Range("$A$1:$J$10000").AutoFilter Field:=10, Criteria1:="0,00"
    Range("A9:J9").Select
    Selection.Copy
    Sheets("архив").Select
    Range("A2").Select
    ActiveSheet.Paste
    Range("A2:J100000").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("архив").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("архив").Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("архив").Sort
        .SetRange Range("A2:J100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Save
    Sheets("прайс").Select
    Range("A9:J9").Select
    Selection.ClearContents
     Selection.EntireRow.Delete
    ActiveSheet.Range("$A$1:$J$10000").AutoFilter Field:=10
    Application.ScreenUpdating = True
End Sub

Sub добавить_строку()
Application.ScreenUpdating = False
ActiveCell.Resize(1).EntireRow.Insert
Application.ScreenUpdating = True
End Sub

Sub Добавить_прайс()
    Worksheets("накладная").Range("B8:H8").Copy                         'копируем строчку с данными из формы
    Range("I4").Select
    n = Worksheets("I4").Range("A100000").End(xlUp).Row                'определяем номер последней строки в таблице прайс
    Worksheets("I4").Cells(n + 1, 1).PasteSpecial Paste:=xlPasteValues 'вставляем в следующую пустую строку
    Worksheets("накладная").Range("F2,H2,E4,E8,F8,G8").ClearContents  'очищаем форму
     Range("A2:G100000").Select
    ActiveWorkbook.Worksheets("I4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("I4").Sort.SortFields.Add Key:=Range("D2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("I4").Sort
        .SetRange Range("A2:G100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("I4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("I4").Sort.SortFields.Add Key:=Range("D2:D100000"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("I4").Sort
        .SetRange Range("A2:G100000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
     
End Sub

Sub FileList()
    Dim V As String
    Dim BrowseFolder As String
     
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку или диск"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы ничего не выбрали!"
            Exit Sub
        End If
    End With
    BrowseFolder = CStr(V)
     
    'добавляем лист и выводим на него шапку таблицы
    Sheets("поиск").Select
    Worksheets("поиск").Range("A1:A100" & Range("A65536").End(xlUp).Row).ClearContents
    With Range("A1")
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A1").Value = "Имя файла"
     
    'вызываем процедуру вывода списка файлов
    'измените True на False, если не нужно выводить файлы из вложенных папок
    ListFilesInFolder BrowseFolder, True
End Sub
 
 
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
 
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(SourceFolderName)
 
    r = Range("A65536").End(xlUp).Row + 1   'находим первую пустую строку
    'выводим данные по файлу
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = "=HYPERLINK(""" & FileItem.Name & """)"
    
        r = r + 1
        X = SourceFolder.Path
    Next FileItem
     
    'вызываем процедуру повторно для каждой вложенной папки
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
 
    Columns("A").AutoFit
    
 Range("A2:A100").Sort Key1:=[A2]
 
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing

 Dim strDirPath, strMaskSearch, strFileName As String
strDirPath = ThisWorkbook.Path & "\" & 2016 & "\" & Range("C1") & "" 'Папка поиска
strMaskSearch = "*.xlsx*" 'Маска поиска
 
'Получаем первый файл соответствующий шаблону
strFileName = Dir(strDirPath & strMaskSearch)

 Set SourceFolder = FSO.getfolder(SourceFolderName)

Private Sub CommandButton5_Click()
CreateObject("Wscript.Shell").Run """" & ThisWorkbook.Path & """"
End Sub

Sub сохранение_новый()
'
'
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="E:\МОЯ РАБОТА\2016\" & CStr(Range("A4")) & "\" & CStr(Range("B4")) & "\" & Range("AC3") & ".xlsx", FileFormat:=51

Application.DisplayAlerts = True
'
End Sub