2020-12-30 07:26:34:34.000   в дату 30.12.2020

f = {"a",(x)=>Date.From(Text.BeforeDelimiter(x[e]," "))},

f = {"a",(x)=>Date.From(Text.BeforeDelimiter(x[e]," "), "ru-RU")} 

Application.CutCopyMode = False

Dim Forma As Range
With Worksheets(2)
 Set Forma = Rows("1:5").Find("KodForma", , xlValues, xlPart) 
    KodForma = Forma.Offset(, 1)
If KodForma = "0682565" Then
            код .....
        Else   
            MsgBox ("Это форма: " & KodForma & " выбрана неверно." & vbNewLine & " Необходимо выбрать форму '0682565'")
            .Close SaveChanges:=False 
        Exit Sub
End If
End With

MyPath = "E:\2_ХХ\_2023\.......\ХХХ_ежедневный"
 MyName = Dir(MyPath & "\" & "1*.xlsx")
 FN = MyPath & "\" & MyName
 Do While MyName <> ""
    FN = MyPath & "\" & MyName
    Excel.Application.Workbooks.Open FN
    MyName = Dir
Loop

Set ra = ws3.Range(ws3.Range("G4"), ws3.Range("G" & B)).Resize(, 11)
  
    Dim rCell As Range, delAr As Range
    
    For Each rCell In ra
        If rCell.Text = "" And rCell.Interior.color = 13408767 Then
            If delAr Is Nothing Then
                Set delAr = Range(rCell.Row & ":" & rCell.Row)
            Else
                Set delAr = Union(delAr, Range(rCell.Row & ":" & rCell.Row))
            End If
        End If
    Next
        If Not delAr Is Nothing Then delAr.Delete

Set ra = ws3.Range(ws3.Range("G4"), ws3.Range("G" & B)).Resize(, 11)

'Столбец один из
Sheets(1).Range("W4:W" & m)
'В случае если есть хотя бы один дубликат, то вывести сообщение:
MsgBox "В столбце имеются дубликаты", vbCritical
'в противном случае
MsgBox "В столбце дубликаты отсутствуют", vbInformation

Sub Test()
Dim Min_date As Date
Dim iCl&, lRow&

iCl = Worksheets(1).Rows(1).Find("Дата").Column
lRow = Worksheets(1).Cells(.Rows.Count, iCl).End(xlUp).Row
Min_date = Application.WorksheetFunction.Min(Columns(iCl))
Min_date = Format(Min_date, "yyyy")
Debug.Print Min_date
Worksheets(1).Name = Min_date
End Sub

Dim arrKey(), arr(), arrS()
Dim lRow&, i&, iKey, iTemp
Dim myRng As Range, delRows As Range
Dim Пример As Worksheet
Set Пример = Worksheets("Пример")
arrKey = Array("ду", "му00", "абк", "атс", "гств", "удтс", "тдчс", "пмп")
With Worksheets("Пример")
    Set myRng = .Range(.Cells(2, 1), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(2, .Columns.Count).End(xlToLeft).Column))
    arr = myRng.Value
End With
ReDim arrNew(1 To UBound(arr, 1), 1 To UBound(arr, 2))
'With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr, 1)
        For Each iKey In arrKey
            iTemp = InStr(arr(i, 9), iKey)
            If iTemp > 0 Then Exit For
        Next
        If iTemp > 0 Then
            If delRows Is Nothing Then
                Set delRows = myRng.Rows(i)
            Else
                Set delRows = Union(delRows, myRng.Rows(i))
            End If
        End If
    Next
  
'End With
  
If Not delRows Is Nothing Then delRows.Delete

avFiles = Application.GetOpenFilename _
                ("Excel files(*.xls*),*.xls*", 1, "Выбрать ф. a, b, v", , True)
    If VarType(avFiles) = vbBoolean Then
'была нажата кнопка отмены - выход из процедуры
        Exit Sub
    End If
        For Each x In avFiles
        s = Dir(x, 16)
        lp = InStrRev(s, ".") 
        sExt = Mid(s, lp, Len(s) - lp + 1)
        sNewFName = InputBox("Укажите новое имя для файла '" & s & ")
        If sNewFName <> "" Then
            FileCopy x, "C:\Users\\" & sNewFName & sExt
        End If
    Next x

FileCopy x, "C:\Users\\" & sNewFName & sExt

Sub Макрос1() 
Sub Макрос2()
Sub Макрос3()

Sub Макрос4()
ThisWorkbook.SaveAs Filename:="C:\Тест\НоваяКнига.xlsx"
End Sub