[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 строк — электронные таблицы уже явно лишние. »