DSN=Excel Files;DefaultDir=U:\;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;

select *from (SELECT * from [U:\0566635.xlsx].`Лист1$` union all SELECT * from [U:\1814525.xlsx].`Лист1$` union all SELECT * from [U:\2201254.xlsx].`Лист1$`) where `Менеджер ` Is Not Null order by `Менеджер `

Subst U: "Полный путь к вашей папке"

Sub insert_into_dbf()
      Dim objRS: Set objRS = CreateObject("ADODB.Recordset")
      objRS.Open "insert into 4726539 SELECT * from [rezultat$] in '" & ThisWorkbook.FullName & "' 'Excel 8.0;'", _
                 "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.path & ";Extended Properties=dBASE IV"
      Set objRS = Nothing
End Sub

Sub ЗаповСпис()
     Dim n&, arr(), number$
     With UserForm1
         If .TextBox1.Value = "" Then MsgBox "Поставте дату": Exit Sub Else
         If .ListBox1.ListCount = 0 Then MsgBox "Список цінностей порожній": Exit Sub Else
         number = Str(.TextBox1)
         arr = Array(number, .TextBox2, .ComboBox1, .ComboBox2, .ComboBox3)
         With Sheets("Список")
             n = .Cells(.Rows.Count, 1).End(xlUp).Row
             .[A1:E1].Offset(n).Value = arr
         End With
         arr = .ListBox1.List
         With Sheets("Список1")
             n = .Cells(.Rows.Count, 1).End(xlUp).Row
             With .[B1:D1].Offset(n).Resize(UBound(arr) + 1)
                 .Value = arr: .Offset(, -1).Resize(, 1) = number
             End With
         End With
     End With
     Unload UserForm1
End Sub

=C2-СЕГОДНЯ()

[<0]"просрочено";[>10]"в работе";"подходит срок"

=ЧИСТРАБДНИ(СЕГОДНЯ();C2;$H$2:$H$29)

Cancel = CloseMode <> 1

Private Sub copy_rows(num)
     Dim b As Boolean
     Dim Список1 As ListObject: Set Список1 = Me.ListObjects("Список1")
     Dim Шаблон As ListObject: Set Шаблон = Parent.Sheets("Шаблон").ListObjects("Шаблон")
rr: If num & "" <> num Or num = "" Then
         If MsgBox("номер не введений, повторити введення?", 36) = 6 Then
             num = Application.InputBox("Введіть номер"): GoTo rr
         Else: Exit Sub
         End If
     ElseIf Список1.ListColumns(1).Range.Find(num, , , 1) Is Nothing Then
         If MsgBox("номер не знайдений, повторити введення?", 36) = 6 Then
             num = Application.InputBox("Введіть номер"): GoTo rr
         Else: Exit Sub
         End If
     End If
     Application.ScreenUpdating = 0: Application.EnableEvents = 0
     If Not Шаблон.DataBodyRange Is Nothing Then Шаблон.DataBodyRange.Delete
     Список1.Range.AutoFilter Field:=1, Criteria1:=num
     Список1.DataBodyRange.Offset(, 1).Resize(, 3).SpecialCells(12).Copy
     Шаблон.HeaderRowRange(2, 2).PasteSpecial xlPasteValues
     Список1.Range.AutoFilter
     Шаблон.Parent.Activate: Шаблон.HeaderRowRange(1).Activate
     Set Список1 = Nothing: Set Шаблон = Nothing
     Application.ScreenUpdating = 1: Application.EnableEvents = 1
End Sub
Private Sub test()
     copy_rows Application.InputBox("Введіть номер")
End Sub

Dim objRS: Set objRS = CreateObject("ADODB.Recordset")

objRS.Open "delete * from 4726539", _
     "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.path & ";Extended Properties=dBASE IV"

sumCell = Join(Application.Transpose(ActiveWorkbook.Worksheets(1).Cells(i + 1, 1).Resize(10)), "")

objRS.Open "delete * from 4726539", _

Sub insert_into_dbf()
     Dim objRS: Set objRS = CreateObject("ADODB.Recordset")
     Dim ConStr$: ConStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & ";Extended Properties=dBASE IV"
     Dim fields$: fields = "kb_a, kk_a, kb_b, kk_b, d_k, summa, vid, ndoc, i_va, da, da_doc, left(nk_a, 38) as nk_a, Left(nk_b, 38) as nk_b, nazn, kod_a, kod_b"
     With Sheets("rezultat").[L:M]: .Replace "і", "i": .Replace "І", "I": End With
     'создаем пустую таблицу и копируем в нее структуру из 4726539.dbf
     objRS.Open "SELECT * INTO tmp FROM 4726539 WHERE 1>1 ", ConStr
     'записываем значения в созданную таблицу
     objRS.Open "insert into tmp SELECT " & fields & " from [rezultat$] in '" & ThisWorkbook.FullName & "' 'Excel 8.0;'", ConStr
     Set objRS = Nothing
     'переименовываем полученный файл
     Name ThisWorkbook.Path & "\TMP.DBF" As ThisWorkbook.Path & "\resultat " & Format(Now(), "DD_MM_YYYY hh_mm_ss") & ".dbf"
End Sub

=МЕДИАНА(МУМНОЖ(-(0&ПОДСТАВИТЬ(ПСТР(A3:E3;ЕСЛИОШИБКА(ПОИСК("|";ПОДСТАВИТЬ(A3:E3;"
";"|"));1)^{0:1}+{0:1};ЕСЛИОШИБКА(ПОИСК("|";ПОДСТАВИТЬ(A3:E3;"
";"|"));1)-{1:-1});".";","));ТРАНСП(-(0&ПОДСТАВИТЬ(ПСТР(A3:E3;ЕСЛИОШИБКА(ПОИСК("|";ПОДСТАВИТЬ(A3:E3;"
";"|"));1)^{0:1}+{0:1};ЕСЛИОШИБКА(ПОИСК("|";ПОДСТАВИТЬ(A3:E3;"
";"|"));1)-{1:-1});".";",")))))