Sub ListFilesInFolder()
  Dim folderPath As String, fileName As String
  Dim fileNum As Integer
  Dim rowNum As Long

  ' Путь к папке
  folderPath = "C:\Прайсы"

  ' Очищаем предыдущий список (если есть)
  Columns("A").ClearContents

  ' Задаем начальную строку для вывода списка
  rowNum = 1

  ' Получаем первый файл в папке
  fileName = Dir(folderPath & "\*.*")

  ' Пока есть файлы в папке
  Do While fileName <> ""
    ' Записываем имя файла в ячейку
    Cells(rowNum, 1).Value = fileName

    ' Увеличиваем номер строки для следующего файла
    rowNum = rowNum + 1

    ' Получаем следующий файл
    fileName = Dir()
  Loop

  ' Автоматически подстраиваем ширину столбца
  Columns(1).AutoFit

  ' Выводим сообщение об успешном завершении
  MsgBox "Список файлов сформирован."
End Sub

Sub УдалитьСтолбцыПоУсловию()

  Dim ws As Worksheet
  Dim lastCol As Long
  Dim i As Long

  ' Устанавливаем рабочий лист (измените "Лист1" на название вашего листа)
  Set ws = ThisWorkbook.Worksheets("Лист1")

  ' Получаем номер последнего столбца с данными в строке 3
  lastCol = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column

  ' Цикл по столбцам, начиная с последнего и двигаясь влево
  For i = lastCol To 1 Step -1

    ' Проверяем, содержит ли ячейка в строке 3 слово "удалить" (без учета регистра)
    If InStr(1, LCase(ws.Cells(3, i).Value), "удалить") > 0 Then

      ' Если найдено, удаляем столбец
      ws.Columns(i).Delete

    End If

  Next i

End Sub

Sub SaveActiveWorkbookAs_3()
    Dim FN As String
    Dim activeWb As Workbook
    Set activeWb = ActiveWorkbook
    
    FN = activeWb.Sheets("Параметры").Range("A1").Value
    activeWb.SaveAs FN
    MsgBox "Файл сохранен как " & FN
    End Sub

="="&ПОДСТАВИТЬ(A2,", ","+")

Sub Макрос5()
'
' Макрос5 Макрос

    Range("A1:O36").Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("A2:A36"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("A1:O36")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub ISBN()
    Dim iTimer As Single
    iTimer = Timer
    
Dim i&
For i = 1 To Cells(Rows.Count, 11).End(xlUp).Row
If Cells(i, 11) Like "978-5-04-*" Or Cells(i, 11) Like "978-5-699-*" Or Cells(i, 11) Like "978-5-00117-*" Or Cells(i, 11) Like "978-5-00146-*" Or Cells(i, 11) Like "978-5-00169-*" Then
Rows(i).Copy
Sheets("Отбор").Cells(Sheets("Отбор").Cells(Rows.Count, 11).End(xlUp).Row + 1, 1).PasteSpecial
End If
Next
Application.CutCopyMode = False
    
   MsgBox "отбор завершен." & vbCrLf & "Время выполнения макроса  " & Format((Timer - iTimer) / 86400, "Long Time"), vbInformation, "ОТБОР ISBN"


End Sub

Sub Макрос8()
'удаление картинок и строк до начала таблицы
ActiveSheet.DrawingObjects.Select
    Selection.Delete
    Rows("1:16").Select
    Selection.Delete Shift:=xlUp
    Selection.AutoFilter
End Sub

Range("A1").Select
'выбор всего листа и снятие слияния ячеек

Cells.Select

    With Selection
        '.HorizontalAlignment = xlCenter
        '.VerticalAlignment = xlBottom
        '.WrapText = False
        '.Orientation = 0
        '.AddIndent = False
        '.IndentLevel = 0
        '.ShrinkToFit = False
        '.ReadingOrder = xlContext
        .MergeCells = False
    End With
    'сортировка по колонке А = код книги в издательстве. 
        Cells.Select
    ActiveWorkbook.Worksheets("TDSheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TDSheet").Sort.SortFields.Add Key:=Range( _
        "A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("TDSheet").Sort
        .SetRange Range("A:W")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Sub nakl_B()
'удаление строк с "накл" в столбце B
Dim cell As Range, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
If Cells(i, 2) Like "*накле*" Then
    If cell Is Nothing Then
        Set cell = Cells(i, 1)
    Else
        Set cell = Union(cell, Cells(i, 1))
    End If
End If
Next i
    If Not cell Is Nothing Then cell.EntireRow.Delete
'удаление строк с "Накл" в столбце B
Dim cell2 As Range, i2 As Long, lr2 As Long
lr2 = Cells(Rows.Count, 1).End(xlUp).Row
For i2 = 2 To lr2
If Cells(i2, 2) Like "*Накле*" Then
    If cell2 Is Nothing Then
        Set cell2 = Cells(i2, 1)
    Else
        Set cell2 = Union(cell2, Cells(i2, 1))
    End If
End If
Next i2
    If Not cell2 Is Nothing Then cell2.EntireRow.Delete
'удаление строк с "накл" в столбце D
Dim cell3 As Range, i3 As Long, lr3 As Long
lr3 = Cells(Rows.Count, 1).End(xlUp).Row
For i3 = 2 To lr3
If Cells(i3, 4) Like "*накле*" Then
    If cell3 Is Nothing Then
        Set cell3 = Cells(i3, 1)
    Else
        Set cell3 = Union(cell3, Cells(i3, 1))
    End If
End If
Next i3
    If Not cell3 Is Nothing Then cell3.EntireRow.Delete
'удаление строк с "накл" в столбце R
Dim cell4 As Range, i4 As Long, lr4 As Long
lr4 = Cells(Rows.Count, 1).End(xlUp).Row
For i4 = 2 To lr4
If Cells(i4, 18) Like "*накле*" Then
    If cell4 Is Nothing Then
        Set cell4 = Cells(i4, 1)
    Else
        Set cell4 = Union(cell4, Cells(i4, 1))
    End If
End If
Next i4
    If Not cell4 Is Nothing Then cell4.EntireRow.Delete
'удаление строк с "Накл" в столбце R
Dim cell5 As Range, i5 As Long, lr5 As Long
lr5 = Cells(Rows.Count, 1).End(xlUp).Row
For i5 = 2 To lr5
If Cells(i5, 18) Like "*Накле*" Then
    If cell5 Is Nothing Then
        Set cell5 = Cells(i5, 1)
    Else
        Set cell5 = Union(cell5, Cells(i5, 1))
    End If
End If
Next i5
    If Not cell5 Is Nothing Then cell5.EntireRow.Delete
End Sub

Sub выделение_всего_листа_снятие_слияния_HL()
'
'выбор всего листа и снятие слияния ячеек

Cells.Select

    With Selection
        '.HorizontalAlignment = xlCenter
        '.VerticalAlignment = xlBottom
        '.WrapText = False
        '.Orientation = 0
        '.AddIndent = False
        '.IndentLevel = 0
        '.ShrinkToFit = False
        '.ReadingOrder = xlContext
        .MergeCells = False
    End With
    'сортировка по колонке А = код книги в издательстве
        Cells.Select
    ActiveWorkbook.Worksheets("TDSheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TDSheet").Sort.SortFields.Add2 Key:=Range( _
        "A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("TDSheet").Sort
        .SetRange Range("A:W")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  'перенос колонки с гиперссылками в крайний правый столбец
    Columns("B:B").Select
    Selection.Cut
    Range("X1").Select
    Selection.Insert Shift:=xlToRight
'выделение ссылки из гиперссылки,вставляет текст в любом месте листа, где есть гиперссылка (справа от ячейки)

Dim HL As Hyperlink

For Each HL In ActiveSheet.Hyperlinks
HL.Range.Offset(0, 1).Value = HL.Address
Next
'преобразование ссылки в обычный текст на всем листе
Cells.Hyperlinks.Delete
End Sub

Sub open_price()
    Dim OP As FileDialog
    Dim x, lf As Long
       Set OP = Application.FileDialog(msoFileDialogOpen)
    With OP
        .AllowMultiSelect = False
        .Title = "Выбрать файл прайса АЗБУКА"
        .Filters.Clear
        .InitialFileName = ""
        If OP.Show = 0 Then Exit Sub
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf)
            Workbooks.Open Filename:=x

            
        Next
    End With
    End Sub

.Replace What:="0", Replacement:="", LookAt:=xlWhole

Sub Formula_Dannye_Vyravnivanie()
'
' Formula_Dannye_Vyravnivanie Макрос
'

'
    Range("A2:K2").Select
    Selection.Copy
    Range("A2:K12000").Select
    ActiveSheet.Paste
    Columns("A:K").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=6
    Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

Sub save_data()
    Dim dtDate As Date 
    dtDate = Date
    
    Dim s As Worksheet 
    Dim wb As Workbook  
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets
        s.Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "export_" & Format(dtDate, "dd-mm-yyyy") & ".xlsx", FileFormat:=51
    Next
    ActiveSheet.Shapes("Button 1").Select 
   Selection.Delete
         End Sub

ChDir "X:\Прайсы"
    Workbooks.Open Filename:="X:\Прайсы\Прайс1.xls"
    Workbooks.Open Filename:="X:\Прайсы\Прайс2.xls"
    Workbooks.Open Filename:="X:\Прайсы\Прайс3.xls"