[решено] выбор данных по дате

[Elizavetta]

Ещё просьба о помощи:)
есть эксель с данными, в нем есть столбец дата, по счету он второй:))
там данные в таком формате
30.09.2015 17:40:22
30.09.2015 17:41:00
30.09.2015 17:51:01
и так далее.

есть папка D:/metrology в ней файлы, каждый называется примерно так "pda391_2015-06-17_03.35.33.dat" (т.е. в названии дата и время и этот формат унифицирован, он может быть только в таком виде)
можно ли сделать макрос, который
1. выберет строки. где разница во времени не менее 10 мин. Т.е. если у нас время идет так
28
38
39
40
41
51
строки со временем 39,40 убираем. Т.е. он должен видеть, что даже если после 51 минуты идет 52, нельзя удалять 51 минуту, т.к. у нее разница с предыдущем времени на 10 мин.
т.е. отталкиваемся по возрастанию времени.
2. когда остались нужные записи . Сличим их со временем в названии файла "pda391_2015-06-17_03.35.33.dat и в папку
D:/metrology1 копируем те dat файлы, которые совпадают со временем.
Просто этих файлов 5000. Я сама не смогу все это в ручную сличить.

[Iska]

есть эксель с данными, в нем есть столбец дата, по счету он второй)
там данные в таком формате
30.09.2015 17:40:22
30.09.2015 17:41:00
30.09.2015 17:51:01
и так далее. »
Упакуйте образец рабочей книги в архив и приложите к сообщению, либо выложите на RGhost.

[Elizavetta]

Iska, вот ссылка
http://rghost.ru/6KKnZJDF2
Переменных может быть много, хоть 1000 столбцов, строк тоже:)
Это просто сокращенный вариант

[Elizavetta]

Неужели там так все сложно?)

[a_axe]

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

[Elizavetta]

a_axe, а можно сделать ,чтобы эта часть pda391_ была изменна, например pda900_
А стоп, кажется сама нашла решение. Немного учусь)

[Elizavetta]

Нет, не получилось:( Как сделать, чтобы pdaxxx_принимал разные числа

[Elizavetta]

Ошибка в этой строчке
n = ActiveSheet.Cells(2, 2).CurrentRegion.Rows.Count

вот файл полный. Правда переменные убрала:)) этот Файл на диск С, а не на D. на D другие pda файлы.
http://rghost.ru/6sqp5N9yS

[a_axe]

Ошибка в этой строчке
n = ActiveSheet.Cells(2, 2).CurrentRegion.Rows.Count »
Есть такое дело - переменная n объявлена как integer, ее максимальное значение допустимо чуть больше 32000, у вас в задаче много больше, соответственно тип должен быть long. Соответственно и обсчитывается файл очень долго.
эта часть pda391_ была изменна, например pda900_ »
Код я подправил, с ограничением - после pda должно обязательно идти 3 цифры, кроме того время указанное после pdaXXX_ не должно быть одинаковым у разных файлов, т.к. один из них будет пропущен.
Public Sub RowsHide_FileCopy_rev1()
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)).SpecialCells(xlCellTypeVisible).Select
For Each myCell In Selection
If myCell.Value Like "##.##.#### #:##:##" Then
strFN = Replace(Replace(myCell.Value, " ", "_0") & ".dat", ":", ".")

Else
strFN = Replace(Replace(myCell.Value, " ", "_") & ".dat", ":", ".")

End If
strFN = Dir("d:\metrology\pda???_" & strFN)
If 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


Добавлено:
В коде поменяйте строчки "C:/Metrology" на "D:/Metrology" и "C:/Metrology1" на "D:/Metrology1", я тестировал на С:, а обратно не переправил.

[Elizavetta]

Код теперь работает:))) Все ясно кроме одного
например вот в экселе значение даты
13.06.2015 21:15:34
вот в папке
D:/Metrology файл
pda156_2015-06-13_21.15.34.dat
но эта дата красным помечена, типа нет файла. :( и конечно же он не скопировался

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