[решено] выбор данных по дате - Компьютерный форум OSzone.net

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)

- - [решено] выбор данных по дате (http://forum.oszone.net/showthread.php?t=310867)

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

Ещё просьба о помощи:)
есть эксель с данными, в нем есть столбец дата, по счету он второй:))
там данные в таком формате
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. Я сама не смогу все это в ручную сличить.

Цитата:

Цитата Elizavetta

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

Упакуйте образец рабочей книги в архив и приложите к сообщению, либо выложите на RGhost.

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

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

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

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

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

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

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

Цитата:

Цитата Elizavetta

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

Есть такое дело - переменная n объявлена как integer, ее максимальное значение допустимо чуть больше 32000, у вас в задаче много больше, соответственно тип должен быть long. Соответственно и обсчитывается файл очень долго.

Цитата:

Цитата Elizavetta

эта часть 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", я тестировал на С:, а обратно не переправил.

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

Цитата:

Цитата Elizavetta

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

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

код

Код:

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

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 строк. Если файлов у вас на большее количество строк - лишние файлы будут пропущены.

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

Цитата:

Цитата Iska

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