Elizavetta, могу предложить следующий код, но с оговорками:
Файлы лежат в папке "D:/metrology" и имеют следующие названия:
pda391_2015-06-17_03.35.33.dat , где красная часть неизменна, синий нолик присутствует, если время менее 10 часов (в экселе в вашем примере этот ноль не отображается), черные символы - меняются.
Эти моменты принципиальны, так как в случае, если программа не найдет файл для копирования, файл будет пропущен.
Разница в 10 минут вычисляется с учетом секунд (т.е. в последовательности 10:05:14, 10:15:13, 10:15:14 второе значение будет пропущено, так как разница между первым и вторым 9:59).
Если необходимый файл успешно найден и скопирован - ячейка заливается зеленым цветом, если файл для копирования не найден - красным.
Первая строка содержит заголовки. Даты содержатся во втором столбце.
Строки не удаляются, вместо этого скрываются (их всегда можно отобразить).
Код желательно предварительно протестить на реальном примере. Если в реальном файле содержание будет отличаться от вашего примера (например даты будут записаны например в виде текста) - код выдаст ошибку.
Код
Код:
Public Sub Metrology()
Dim i As Integer, j As Integer, n As Integer
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)).SpecialCells(xlCellTypeVisible).Select
For Each myCell In Selection
If myCell.Value Like "##.##.#### #:##:##" Then
strFN = "pda391_" & Replace(Replace(myCell.Value, " ", "_0") & ".dat", ":", ".")
Else
strFN = "pda391_" & Replace(Replace(myCell.Value, " ", "_") & ".dat", ":", ".")
End If
If Dir("d:\metrology\" & strFN) <> "" Then
FileCopy "d:\metrology\" & strFN, "d:\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
End Sub
Как сделать, чтобы pdaxxx_принимал разные числа
