Sub пакетное_копирование_строки_по_условию()
    Dim Folder As String
    Dim wb As String
    Dim objWb As Workbook
    Dim workWb As Workbook
    Dim i As Integer
    Set workWb = ActiveWorkbook  'Запоминаем активную книгу

    'Показываем диалог выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку, файлы в которой нужно обработать"
        .ButtonName = "Выбрать"
        .AllowMultiSelect = False
        If .Show Then Folder = .SelectedItems(1) Else Exit Sub
    End With
    'Начинаем читать файлы из папки
    wb = Dir(Folder & Application.PathSeparator & "*.xlsx")
    While Len(wb) > 0
        i = i + 1
        wb = Folder & Application.PathSeparator & wb
        Set objWb = Workbooks.Open(wb)

    Application.ScreenUpdating = False
    
    'Начинаем копировать строки, удовлетваряющие условию в активную книгу
    With objWb.Sheets(1)
            lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
            For j = 2 To lastRow
                If .Cells(j, "B") Like "Описание" Then Sheets(1).Row.Copy ................................... 'тут я не могу сообразить
                End If
            Next
        End With
    With Application
        .ScreenUpdating = False: .CutCopyMode = False
    End With
    
    'Отключаем проверку совместимости при закрытии и сохранении файлов
    ActiveWorkbook.CheckCompatibility = False
    objWb.Close True
    wb = Dir    'читаем следующий файл
    Wend
End Sub

Sub УдалениеСтрокПоУсловию()
    Dim ra As Range, delra As Range
    Application.ScreenUpdating = False    ' отключаем обновление экрана

    ТекстДляПоиска = "Наименование ценности"    ' удаляем строки с таким текстом

    ' перебираем все строки в используемом диапазоне листа
    For Each ra In ActiveSheet.UsedRange.Rows
        ' если в строке найден искомый текст
        If Not ra.Find(ТекстДляПоиска, , xlValues, xlPart) Is Nothing Then
            ' добавляем строку в диапазон для удаления
            If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
        End If
    Next
    ' если подходящие строки найдены - удаляем их
    If Not delra Is Nothing Then delra.EntireRow.Delete
End Sub

Sub test()
    Dim Folder As String
    Dim wb As String
    Dim objWb As Workbook
    Dim workWb As Workbook
    Dim i As Integer
    Set workWb = ActiveWorkbook  'Запоминаем активную книгу

    'Показываем диалог выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку, файлы в которой нужно обработать"
        .ButtonName = "Выбрать"
        .AllowMultiSelect = False
        If .Show Then Folder = .SelectedItems(1) Else Exit Sub
    End With
    'Начинаем читать файлы из папки
    wb = Dir(Folder & Application.PathSeparator & "*.xls")
    While Len(wb) > 0
        i = i + 1
        wb = Folder & Application.PathSeparator & wb
        Set objWb = Workbooks.Open(wb)

        With objWb.Sheets(1)
            lastRow = .Cells(.Rows.Count, 6).End(xlUp).Row
            For j = 2 To lastRow
                If .Cells(j, "F") Like "шт" Then
                   .Cells(j, "F") = "ед"
                ElseIf .Cells(j, "E") Like "шт" Then
                       .Cells(j, "G") = "шт"
                ElseIf .Cells(j, "E") Like "шт" Then
                       .Cells(j, "E") = ""
                End If
            Next
        End With

        ActiveWorkbook.CheckCompatibility = False
        objWb.Close True
        wb = Dir    'читаем следующий файл
    Wend
End Sub
 

Sub замена_части_текста_в_ячейке()
    Dim Folder As String
    Dim wb As String
    Dim objWb As Workbook
    Dim workWb As Workbook
    Dim i As Integer
    Set workWb = ActiveWorkbook  'Запоминаем активную книгу

    'Показываем диалог выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку, файлы в которой нужно обработать"
        .ButtonName = "Выбрать"
        .AllowMultiSelect = False
        If .Show Then Folder = .SelectedItems(1) Else Exit Sub
    End With
    'Начинаем читать файлы из папки
    wb = Dir(Folder & Application.PathSeparator & "*.xls")
    While Len(wb) > 0
        i = i + 1
        wb = Folder & Application.PathSeparator & wb
        Set objWb = Workbooks.Open(wb)

     'Копируем и вставляем диапазон
    Application.ScreenUpdating = False
    Лист2.Range("A1:F100").Copy
    With Лист1.Range("F25")
              .PasteSpecial Paste:=xlPasteValues
              .PasteSpecial Paste:=xlPasteFormats
              .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    With Application
        .ScreenUpdating = False: .CutCopyMode = False
    End With

    'Отключаем проверку совместимости при закрытии и сохранении файлов
    ActiveWorkbook.CheckCompatibility = False
    objWb.Close True
    wb = Dir    'читаем следующий файл
    Wend
End Sub
 

Sub имя_листа_в_ячейку()
Cells(6, 3).Value = Sheets(2).Name
Cells(6, 3).Value = Sheets(3).Name
Cells(6, 3).Value = Sheets(4).Name
Cells(6, 3).Value = Sheets(5).Name
Cells(6, 3).Value = Sheets(6).Name
Cells(6, 3).Value = Sheets(7).Name
Cells(6, 3).Value = Sheets(8).Name
Cells(6, 3).Value = Sheets(9).Name
Cells(6, 3).Value = Sheets(10).Name
Cells(6, 3).Value = Sheets(11).Name
Cells(6, 3).Value = Sheets(12).Name
Cells(6, 3).Value = Sheets(13).Name
Cells(6, 3).Value = Sheets(14).Name
Cells(6, 3).Value = Sheets(15).Name
End Sub

Sub ins_row()
Dim i As Long, sVal As String
sVal = "Выключатели автоматические,Шестеренные" 'здесь указать список
For i = Cells(Rows.Count, 6).End(xlUp).Row To 2 Step -1
If InStr(sVal, Cells(i, 6)) > 0 Then Cells(i + 1, 6).Resize(1).EntireRow.insert
If InStr(sVal, Cells(i, 6)) > 0 Then Cells(i + 1, 6).Resize(1).EntireRow.insert
Next
End Sub
 

Sub zamena()
Dim i, lastRow As Long
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    For i = 2 To lastRow
        If Cells(i, 3) = "Замена отвода * " Then ' звездочка для поиска любых символов после
            Cells(i, 4) = "м"
        End If
    Next
End Sub

=СЧЁТЕСЛИ('[01_Аппараты.xlsx]01.71'!$C$5:$C$467;$A$1&"*")

=СЧЁТЕСЛИМН('[01_Аппараты.xlsx]01.71'!$C$5:$C$467;$A$1&"*";'[01_Аппараты.xlsx]01.71'!$D$5:$D$467;"создана"&"*")

=СЧЁТЕСЛИМН('[01_Аппараты.xlsx]01.71'!$C$5:$C$467;$A$1&"*";'[01_Аппараты.xlsx]01.71'!$D$5:$D$467;D$5)

=СЧЁТЕСЛИ('\\Ws1210002\обмен\00_Реестр\[01_Аппараты.xlsx]01.71'!$C$5:$C$467;$A$1&"*")

=СЧЁТЕСЛИМН('\\Ws1210002\обмен\00_Реестр\[01_Аппараты.xlsx]01.71'!$C$5:$C$467;$A$1&"*";'\\Ws1210002\обмен\00_Реестр\[01_Аппараты.xlsx]01.71'!$D$5:$D$467;"создана"&"*")

=СЧЁТЕСЛИМН('\\Ws1210002\обмен\00_Реестр\[01_Аппараты.xlsx]01.71'!$C$5:$C$467;$A$1&"*";'\\Ws1210002\обмен\00_Реестр\[01_Аппараты.xlsx]01.71'!$D$5:$D$467;D$5)