If Date > "01.01.2024" Then Exit Sub

   Set wb = Application.Workbooks.Open(sFolder & sFiles)
        
   Columns("B:S").Delete
   Rows("1:3").Delete
   Columns("A:A").Replace What:="~(Годен*", Replacement:=""
   Columns("A:A").Replace What:="~(Без*", Replacement:=""
   Range("A:A").RemoveDuplicates 1
      
   wb.Close True

 
 
  ЛЕЙКОПЛАСТЫРЬ ПЕРЦОВЫЙ 6Х10 /НОВОСИБХИМФАРМ/ ,,,,,,,,,,,
 
 
  СПЛАТ ЗУБ.ЩЕТКА BLACKWOOD СРЕДНЯЯ [SPLAT]  ,,,,,,,,,,,
 
 
  ,,,,,,,,,,,
 
 
  ,,,,,,,,,,,
 
 
  ,,,,,,,,,,,
 

Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    Dim wb As Workbook
    On Error Resume Next
    
    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
     
    lLastRowThis = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Библиотека = ThisWorkbook.ActiveSheet.Range("A1:B" & lLastRowThis)
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        
        Set wb = Application.Workbooks.Open(sFolder & sFiles)
        
   
   Columns("B:S").Delete
   Rows("1:3").Delete


        lLastRowOpen = wb.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        lLastColOpen = wb.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        OpenFile = wb.ActiveSheet.Range("A1:A" & lLastRowOpen)
         
        Columns("А1:А").Replace What:="~(*~)", Replacement:="" 'тут я столкнулся со сложностью
 
       Range("A1:A").RemoveDuplicates 1, xlNo
     

    wb.Close true 
        sFiles = Dir
    Loop
    
    Application.ScreenUpdating = True
End Sub

(z)=>
let
    Источник = Excel.Workbook(File.Contents(z), null, true),
    Лист1_Sheet = Источник{[Item="Лист1",Kind="Sheet"]}[Data],
    #"Удаленные столбцы" = Table.RemoveColumns(Лист1_Sheet,{"Column2", "Column3", "Column5", "Column6", "Column7", "Column8", "Column9", "Column10", "Column11", "Column12", "Column13", "Column14", "Column15", "Column16", "Column17", "Column18", "Column19"}),
    #"Удаленные верхние строки" = Table.Skip(#"Удаленные столбцы",3),
    #"Текст в верхнем регистре" = Table.TransformColumns(#"Удаленные верхние строки",{{"Column1", Text.Upper, type text}}),
    пробелы = Table.TransformColumns( #"Текст в верхнем регистре",{"Column1", Text.Trim, type text}),
//тут я заменяю короткие строчки, если нашлись более длинные с таким же началом
    descr = List.Buffer(List.Distinct(пробелы[Column1])),
    full_descr =   
        Table.AddColumn(
            пробелы, 
            "description",
            (x) => List.Select(descr, (w) => Text.Contains(w, x[Column1]) and w <> x[Column1]){0}? ?? x[Column1]),
    #"Переупорядоченные столбцы" = Table.ReorderColumns(full_descr,{"Column1", "description", "Column4"}),
    #"Удаленные столбцы1" = Table.RemoveColumns(#"Переупорядоченные столбцы",{"Column1"}),
//тут я обращаюсь к другому запрошенному файлу
lst = List.Buffer(искомое[Столбец2]),
found = Table.AddColumn(#"Удаленные столбцы1", "позиция", (x) => List.Select(lst, (w) => Text.Contains(x[description], w)){0}?),
    #"Разделить столбец по разделителю" = Table.SplitColumn(found, "description", Splitter.SplitTextByAnyDelimiter({" тбл", " 0", " 1", " 2", " 3", " 4", " 5", " 6", " 7", " 8", " 9", " /", "№", ". ", " [", " (Год", " (Без"}, QuoteStyle.None, false), {"Column1.1", "Column1.2"}),
    #"Удаленные столбцы2" = Table.RemoveColumns(#"Разделить столбец по разделителю",{"Column1.2"}),
    #"Объединенные столбцы" = Table.CombineColumns(#"Удаленные столбцы2",{"Column1.1", "позиция"},Combiner.CombineTextByDelimiter(" ", QuoteStyle.None),"Сведено")
in
    #"Объединенные столбцы"

let
    Источник = Excel.Workbook(БЛА БЛА), null, true),
    Лист1_Sheet = Источник{[Item="Лист1",Kind="Sheet"]}[Data],
    #"Удаленные столбцы" = Table.RemoveColumns(Лист1_Sheet,{"Column2", "Column3", "Column4", "Column5", "Column6", "Column7", "Column8", "Column9", "Column10", "Column11", "Column12", "Column13", "Column14", "Column15", "Column16", "Column17", "Column18", "Column19"}),
    #"Удаленные верхние строки" = Table.Skip(#"Удаленные столбцы",3),
    #"Сортированные строки" = Table.Sort(#"Удаленные верхние строки",{{"Column1", Order.Ascending}}),
    #"Разделить столбец по разделителю" = Table.SplitColumn(#"Сортированные строки", "Column1", Splitter.SplitTextByEachDelimiter({"(Годен"}, QuoteStyle.Csv, false), {"Column1.1", "Column1.2"}),
    #"Измененный тип" = Table.TransformColumnTypes(#"Разделить столбец по разделителю",{{"Column1.1", type text}, {"Column1.2", type text}}),
    #"Удаленные столбцы1" = Table.RemoveColumns(#"Измененный тип",{"Column1.2"}),
    объект = Table.AddColumn(#"Удаленные столбцы1", "Column3", each Text.Trim([Column1.1])),


   
    descr = List.Buffer(List.Distinct(объект[Column3])),
    full_descr =   
        Table.AddColumn(
            объект, 
            "description",
            (x) => List.Select(descr, (w) => Text.Contains(w, x[Column3]) and w <> x[Column3]){0}? ?? x[Column3]),//до этого места все прекрасно работает

    искомое = List.Buffer(Excel.CurrentWorkbook(){[Name="искомое"]}[Content][Столбец2]), //тут я незнаю как обратится к другому подключению
    found = Table.AddColumn(full_descr, "позиция", (x) => List.Select(искомое, (w) => Text.Contains(x[description], w)){0}?)
in
    found

<html lang="ru"> <head>    <meta charset="utf-8"/>    <title>БЛА БЛА</title>    <base href="/бла/"/>
     <meta name="viewport" content="width=device-width, initial-scale=1"/> 
  <link type="image/png" sizes="32x32" rel="icon" href="./favicon-32.png"/> 
<link rel="stylesheet" href="styles.c3ce6e3af0134bf988bb.css"></head> 
<body>    <div class="index-content">      <div class="common-bkg"></div>   
  <app-root></app-root>    </div>  <script
src="runtime.a01c58b958d6cdc5bdab.js" defer></script><script
src="polyfills.377cf92b86fbe9bfd4c7.js" defer></script><script
src="scripts.9a69fe6b98afaed077f5.js" defer></script><script
src="main.9d941841bd24e3e4beaf.js" defer></script></body></html>

<div class="cdk-overlay-container"></div>

Public Sub test()
Dim xhr As New XMLHTTP60
xhr.Open "GET",
"https://блабла",
False
xhr.send
Debug.Print xhr.responseText

End Sub

a =
Table.SplitColumn(#"Измененный тип1", "Column1",
Splitter.SplitTextByAnyDelimiter({" 0", " 1", " 2", " 3", " 4", " 5", " 6", " 7", " 8", " 9", " /", " №", ". ", " [", " ("},
QuoteStyle.None, false), {"Column1.1", "Column1.2"}),

Sub Consolidated_Range_of_Books_and_Sheets()
    Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long
    Dim oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles
    Dim wbAct As Workbook
    Dim bPasteValues As Boolean, IsPasteSheetName As Boolean
 
    On Error Resume Next
    'Выбираем диапазон выборки с книг
    Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
                                           "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
                                           vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
    'для указания диапазона без диалогового окна:
    'Set iBeginRange = Range("A1:A10") 'диапазон указывается нужный
    'Если диапазон не выбран - завершаем процедуру
    If iBeginRange Is Nothing Then
        Exit Sub
    End If
    'Указываем имя листа
    'Допустимо указывать в имени листа символы подставки ? и *.
    'Если указать только * то данные будут собираться со всех листов
    sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
    'Если имя листа не указано - данные будут собраны со вех листов
    If sSheetName = "" Then
        sSheetName = "*"
    End If
    'добавлять ли имя листа в начало таблицы
    IsPasteSheetName = (MsgBox("Вставлять имя листа первым столбцом?", vbQuestion + vbYesNo, "www.wxcel-vba.ru") = vbYes)
    On Error GoTo 0
    'Запрос - вставлять на результирующий лист все данные
    'или только значения ячеек (без формул и форматов)
    bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "www.wxcel-vba.ru") = vbYes)
    'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
    If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "www.wxcel-vba.ru") = vbYes Then
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        If VarType(avFiles) = vbBoolean Then Exit Sub
        bPolyBooks = True
        lCol = 1
    Else
        avFiles = Array(ThisWorkbook.FullName)
    End If
    If IsPasteSheetName Then
        lCol = lCol + 1
    End If
    'отключаем обновление экрана, автопересчет формул и отслеживание событий
    'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
    'создаем новый лист в книге для сбора
    Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    'если нужно сделать сбор данных на новый лист книги с кодом
    'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    'цикл по книгам
    For li = LBound(avFiles) To UBound(avFiles)
        If bPolyBooks Then
            Set wbAct = Workbooks.Open(Filename:=avFiles(li))
        Else
            Set wbAct = ThisWorkbook
        End If
        oAwb = wbAct.Name
        'цикл по листам
        For Each wsSh In wbAct.Sheets
            If wsSh.Name Like sSheetName Then
                'Если имя листа совпадает с именем листа, в который собираем данные
                'и сбор идет только с активной книги - то переходим к следующему листу
                If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
                With wsSh
                    Select Case iBeginRange.Count
                    Case 1 'собираем данные начиная с указанной ячейки и до конца данных
                        lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
                        iLastColumn = .Cells.SpecialCells(xlLastCell).Column
                        sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
                    Case Else 'собираем данные с фиксированного диапазона
                        sCopyAddress = iBeginRange.Address
                    End Select
                    lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
                    'определяем для копирования диапазон только заполненных данных на листе
                    Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress))
                    'вставляем имя книги, с которой собраны данные
                    If lCol > 0 Then
                        If bPolyBooks Then
                            wsDataSheet.Cells(lLastRowMyBook, 1).Resize(rCopy.Rows.Count).Value = oAwb
                        End If
                        If IsPasteSheetName Then
                            wsDataSheet.Cells(lLastRowMyBook, lCol).Resize(rCopy.Rows.Count).Value = .Name
                        End If
                    End If
                    'если вставляем только значения
                    If bPasteValues Then
                        rCopy.Copy
                        wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
                        wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteFormats
                    Else 'если вставляем все данные ячеек(формулы, форматы и т.д.)
                        rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
                    End If
                End With
            End If
NEXT_:
        Next wsSh
        If bPolyBooks Then
            wbAct.Close False
        End If
    Next li
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lCalc
    End With
End Sub

Sub Consolidated_Range_of_Books_and_Sheets()
    Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long
    Dim oAwb As String, sCopyAddress As String, sSheetName As String
    Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles
    Dim wbAct As Workbook
    Dim bPasteValues As Boolean, IsPasteSheetName As Boolean
 
    On Error Resume Next
    'Выбираем диапазон выборки с книг
    Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
                                           "Указатьт ячейку на листе, с какого места начинать сбор ", Type:=8)
    'для указания диапазона без диалогового окна:
    'Set iBeginRange = Range("A1:A10") 'диапазон указывается нужный
    'Если диапазон не выбран - завершаем процедуру
    If iBeginRange Is Nothing Then
        Exit Sub
    End If
    
    
        sSheetName = "*"
  
    'добавлять ли имя листа в начало таблицы
    IsPasteSheetName = vbNo
    On Error GoTo 0
    'Запрос - вставлять на результирующий лист все данные
    'или только значения ячеек (без формул и форматов)
    bPasteValues = vbNo
    'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
    
        avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
        
        bPolyBooks = True
        lCol = 1
    
    If IsPasteSheetName Then
        lCol = lCol + 1
    End If

Private Sub Worksheet_Activate()
     Load UserForm10
     UserForm10.Show
     If ThisWorkbook.Sheets("Схема").Cells(2, 37) <> 0 And
ThisWorkbook.Sheets("Схема").Cells(3, 37) <> 0 Then
         UserForm10.Left = ThisWorkbook.Sheets("Схема").Cells(2, 37)
         UserForm10.Top = ThisWorkbook.Sheets("Схема").Cells(3, 37)
     Else
         UserForm10.Left = 900
         UserForm10.Top = 100
     End If
     If ThisWorkbook.Sheets("Схема").Cells(4, 37) = 1 Then
         ThisWorkbook.Sheets("Схема").Cells(4, 37) = 0
         Call UserForm10.DrawShema
     End If
End Sub

Private Sub Worksheet_Deactivate()
'   ThisWorkbook.Sheets("Схема").Cells(2, 37) = UserForm10.Left
'   ThisWorkbook.Sheets("Схема").Cells(3, 37) = UserForm10.Top
     UserForm10.Hide
     Unload UserForm10
End Sub

With Application.FileDialog(msoFileDialogFolderPicker)

With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)

 For n = 1 To UBound(Библиотека)
            For x = 1 To UBound(OpenFile)
                If OpenFile(x, 1) Like Библиотека(n, 1) & "*" Then
                    wb.ActiveSheet.Cells(x + 3, lLastColOpen + 1) = Библиотека(n, 2)
                End If
            Next x
        Next n

If OpenFile(x, 1) Like Библиотека(n, 1) & "*" And OpenFile(x, 15) > "01.01.2019" Then

wb.ActiveSheet.Cells(x + 3, lLastColOpen + 1) = Библиотека(n, 2)

If OpenFile(x, 1) Like Библиотека(n, 1) & "*" And OpenFile(x, 15) < "01.01.2019" Then

wb.ActiveSheet.Cells(x + 3, lLastColOpen + 1) = Библиотека(n, 3)