[a_axe]

но эта дата красным помечена, типа нет файла. и конечно же он не скопировался »

Это происходит из-за разного порядка представления дат в экселе и в названии файлов. Попробуйте код ниже, он временно переформатирует даты, затем вернет их первоначальное форматирование.
Код написан для диска С:.

код

Код:

Public Sub RowsHide_FileCopy_rev3()
    Dim i As Long, j As Long, n As Long
    Dim myCell As Range
    Dim strFN As String
    Dim answ As Integer
    Dim diff As Double
    diff = 1 / 24 / 6
    n = ActiveSheet.Cells(2, 2).CurrentRegion.Rows.Count
    For i = 2 To n
        j = i + 1
        
        Do While j <= n And ActiveSheet.Cells(j, 2).Value - ActiveSheet.Cells(i, 2).Value <= diff
            ActiveSheet.Rows(j).Hidden = True
            j = j + 1
        Loop
        
        i = j - 1
        
    Next
    ActiveSheet.Rows(1).Hidden = True
    Intersect(ActiveSheet.Cells(2, 2).CurrentRegion, ActiveSheet.Columns(2)).Select
    Selection.NumberFormat = "yyyy/mm/dd h:mm:ss"
    Selection.SpecialCells(xlCellTypeVisible).Select
    For Each myCell In Selection
        
        If myCell.Value Like "##.##.#### #:##:##" Then
            strFN = Replace(Replace(Replace(myCell.Text, ".", "-"), " ", "_0") & ".dat", ":", ".")
            
        Else
            strFN = Replace(Replace(Replace(myCell.Text, ".", "-"), " ", "_") & ".dat", ":", ".")
            
        End If
        strFN = Dir("c:\metrology\pda???_" & strFN)
        
        If strFN <> "" Then
            
            FileCopy "c:\metrology\" & strFN, "c:\metrology1\" & strFN
            myCell.Interior.Color = vbGreen
        Else
            '            answ = MsgBox("Отсутствует файл d:\metrology\" & strFN & ", он будет пропущен. Продолжить обработку дальше?", vbYesNo, "Ошибка!")
            '            If answ = vbNo Then Exit Sub
            myCell.Interior.Color = vbRed
        End If
    Next
    ActiveSheet.Rows(1).Hidden = False
    Intersect(ActiveSheet.Cells(2, 2).CurrentRegion, ActiveSheet.Columns(2)).Select
    Selection.NumberFormat = "dd/mm/yyyy h:mm"
End Sub

[a_axe]

Elizavetta, выкладываю озвученную в личке обратную задачу: перебор имеющихся файлов, поиск соответствующих записей на листе Excel и копирование на новый лист найденных ячеек+диапазона ниже них, укладывающихся в разницу по времени 20 минут.

код

Код:

Public Sub files2newSheet()
    Dim i As Long, j As Long, k As Long
    Dim strPath  As String
    Dim dCell As Range
    Dim DataSheet As Worksheet
    Dim NewSheet As Worksheet
    Set DataSheet = ActiveSheet
    Set NewSheet = Worksheets.Add
    DataSheet.Activate
    strPath = Dir("c:\\Metrology\*.dat")
    k = 1
    
    Do While strPath <> "" And k < 1000000
        strPath = Replace(strPath, ".dat", "")
        strPath = Replace(strPath, ".", ":")
        strPath = Mid(strPath, 9, 2) & "." & Mid(strPath, 6, 2) _
        & "." & Left(strPath, 4) & "  " & Right(strPath, 8)
        strPath = Replace(strPath, " 0", " ")
        
        If Not Intersect(DataSheet.UsedRange, DataSheet.Columns(2)).Find(CDate(strPath)) Is Nothing Then
            i = Intersect(DataSheet.UsedRange, DataSheet.Columns(2)).Find(CDate(strPath)).Row
            j = 0
            Do
                j = j + 1
            Loop Until DataSheet.Cells(i + j, 2).Value - DataSheet.Cells(i, 2).Value > 20 / 24 / 60
            j = j - 1
            
            
            DataSheet.Cells(i, 2).Interior.ColorIndex = 3
            Range(DataSheet.Cells(i, 2), DataSheet.Cells(i + j, 2)).Copy
            NewSheet.Cells(k, 1).Insert
            k = k + j + 1
        End If
        strPath = Dir()
        
    Loop
    
    
    
    Set DataSheet = Nothing
    Set NewSheet = Nothing
    
End Sub

Поскольку речь идет о многократном копировании одних и тех же диапазонов, лимит записей на новом листе установлен на 1000000 строк. Если файлов у вас на большее количество строк - лишние файлы будут пропущены.

Не могу не заметить, что задача не для Экселя:

На том, что больше 1000 строк — электронные таблицы уже явно лишние. »