Как найти наиболее близкое совпадение со временем, которое я указываю вниз по столбцу чч: мм: сс, то есть выборка производится 24 часа в сутки? - PullRequest
0 голосов
/ 19 апреля 2020

Моя выборка записывает набор данных каждые 5, 6 или 7 секунд, в зависимости от возвращаемых данных. Так что, если использовать подход «Найти все», чтобы найти, например, 6:00:00, и в 6:00:00 (6:00 AM) было получено чтение, я бы взамен получил адрес строки 6: 00:00 было, и если бы было чтение в 18:00:00 (18:00), я также вернул бы этот адрес. Проблема в том, что если в 6:00:00 или 18:00:00 нет выборки, я ничего не получаю. То, что я ищу, - это способ вернуть два адреса в день, чтобы создать дневной диапазон между этими двумя адресами. Если я укажу 6:00:00, но в одной строке будет 5:59:58, а в следующей строке - 6:00:03, я бы хотел иметь возможность захватить адрес 5:59: 58 отметка времени. Затем снова в 18:00:00 (18:00), если не точно в 18:00:00, то ближе всего, как описано выше. Таким образом, в конце я получу набор адресов в день, чтобы собрать их в качестве диапазона. Если первая выборка в начале набора данных начинается после моего указанного времени, то, каким бы ни было это время, будет время начала первых дней. Аналогичным образом, если время последней выборки набора данных заканчивается раньше заданного времени, то отметкой времени будет время окончания последних дней. Я надеюсь, что кто-то может посоветовать. Кодировка, которую я пробовал:

Sub find_All_2()

    'This macro finds all cells containing "6:00:00" in Range("C:C")
    '
    'This works to find 6:00:00 and places the address in the Immediate window.
    '$C$30416
    '$C$38240
    '$C$45890
    '$C$53694
    '$C$61357
    '$C$84640
    '$C$92292, row 100095 has 18:00:02, and misses it because its not 6:00:00
    '$C$161331
    'However, if I search for 7:00:00, this macro only finds 2
    '$C$77468, because all of the others are not exactly 7:00:00.
    '$C$139112
    '

    Dim FoundCell As Range
    Dim LastCell As Range
    Dim FirstAddr As String
    With Range("C:C")
        Set LastCell = .Cells(.Cells.count)
    End With
    Set FoundCell = Range("C:C").Find(what:="7:00:00", after:=LastCell)

    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If
    Do Until FoundCell Is Nothing
    Debug.Print FoundCell.Address
    Set FoundCell = Range("C:C").FindNext(after:=FoundCell)
    If FoundCell.Address = FirstAddr Then
        Exit Do
    End If
Loop
'
End Sub

Ответы [ 2 ]

1 голос
/ 20 апреля 2020

Вы можете сделать что-то вроде этого:

Sub Tester()

    Dim rng As Range, ws As Worksheet, c As Range

    Set ws = ActiveSheet
    Set rng = ws.Range("A1:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row)

    Set c = ClosestTimeCell(rng, "06:30")
    Debug.Print c.Address, Format(c.Value, "hh:mm:ss")

    Set c = ClosestTimeCell(rng, "18:30")
    Debug.Print c.Address, Format(c.Value, "hh:mm:ss")

End Sub

'return the cell in rng with the closest match to the provided time
Function ClosestTimeCell(rng As Range, theTime As String) As Range
    Dim diffs, pos
    'Get all the absolute differences from the desired time
    '  Returns an array of values (evaluated as an array formula)
    diffs = rng.Parent.Evaluate("ABS(" & rng.Address & "-TIMEVALUE(""" & theTime & """))")
    'get the position of the smallest difference
    pos = Application.Match(Application.Min(diffs), diffs, 0)
    Set ClosestTimeCell = rng.Cells(pos)
End Function

РЕДАКТИРОВАТЬ - после просмотра исходного файла ...

Подход к формуле массива:

enter image description here

Подход VBA:

Sub Tester()

    Dim rng As Range, ws As Worksheet, rngDays As Range, rngTimes As Range
    Dim startTime, endTime, numDays, dict As Object, data()
    Dim startD, endD, k, bFirst As Boolean
    Dim days, times, i As Long, d, t, currentDay, n As Long, v, indx As Long
    Set dict = CreateObject("scripting.dictionary")

    Set ws = Sheets("Sheet1")
    Set rngDays = ws.Range("B1:B" & ws.Cells(Rows.Count, 2).End(xlUp).Row)
    startTime = ws.Range("H2").Value
    endTime = ws.Range("I2").Value

    days = rngDays.Value
    times = rngDays.Offset(0, 1).Value

    'get the unique days to assess
    'we started from row 1 to avoid offsets, so ignore the headers...
    For i = 2 To UBound(days, 1)
        If Not dict.exists(days(i, 1)) Then dict.Add days(i, 1), dict.Count + 1
    Next i

    'use this for tracking start/end time differences (col 1 and 3)
    '  and row numbers with smallest deltas (cols 2 and 4)
    ReDim data(1 To dict.Count, 1 To 4)

    For i = 2 To UBound(days, 1)
        indx = dict(days(i, 1)) '>>  "row" in 2-D tracking array
        bFirst = IsEmpty(data(indx, 1)) 'first row for this day?

        t = times(i, 1)
        startD = CDbl(Abs(t - startTime)) 'start delta
        endD = CDbl(Abs(t - endTime))     'end delta

        'compare, and track smallest deltas and row numbers
        If bFirst Or startD < data(indx, 1) Then
            data(indx, 1) = startD
            data(indx, 2) = i
        End If
        If bFirst Or endD < data(indx, 3) Then
            data(indx, 3) = endD
            data(indx, 4) = i
        End If

    Next i

    'print each day and "best match" start/end time rows
    For Each k In dict
        Debug.Print k, data(dict(k), 2), data(dict(k), 4)
    Next k

End Sub
0 голосов
/ 20 апреля 2020

После тестирования (и некоторого обучения) я закончил работу над решением, которое как бы противоречило моему предыдущему ответу, поэтому вот что я придумал.

Option Explicit

Option Explicit

Sub find_All_2()
Dim LastUsedRow As Long
Dim FirstCell As Range
Dim LastCell As Range
Dim myDayRange As Range
Dim InputTime As String
Dim CellToCheck As Variant
Dim TimeVal As Variant
Dim TimeToEvaluate As String
Dim SecondsCounter As Single

InputTime = FormatNumber("12:00:02", 5)

With ThisWorkbook.Sheets("Sheet1")
    LastUsedRow = .Cells(.Rows.Count, 3).End(xlUp).Row

    For CellToCheck = LastUsedRow To 1 Step -1
        If LastCell Is Nothing Then
            TimeVal = Split(FormatNumber(.Range("C" & CellToCheck).Value, 5), ".")
            If Format("0." & TimeVal(1), "0.00000") = InputTime Then
                Set LastCell = .Cells(CellToCheck, 3)
                Exit For
            Else
                For SecondsCounter = -0.00008 To 0.00008 Step 0.00001
                    SecondsCounter = Round(SecondsCounter, 5)
                    TimeToEvaluate = CDec("0." & TimeVal(1)) + SecondsCounter
                    If Format(TimeToEvaluate, "0.00000") = InputTime Then
                        Set LastCell = .Cells(CellToCheck, 3)
                        Exit For
                    End If
                Next SecondsCounter
            End If
        End If
    Next CellToCheck

    If LastCell Is Nothing Then
        Debug.Print "No LastCell Found"
        Exit Sub
    End If

     For CellToCheck = LastCell.Row - 1 To 1 Step -1
        If FirstCell Is Nothing Then
            TimeVal = Split(FormatNumber(.Range("C" & CellToCheck).Value, 5), ".")
            If Format("0." & TimeVal(1), "0.00000") = InputTime Then
                Set FirstCell = .Cells(CellToCheck, 3)
                Exit For
            Else
                For SecondsCounter = -0.00006 To 0.00008 Step 0.00001
                    SecondsCounter = Round(SecondsCounter, 5)
                    TimeToEvaluate = CDec("0." & TimeVal(1)) + SecondsCounter
                    If Format(TimeToEvaluate, "0.00000") = InputTime Then
                        Set FirstCell = .Cells(CellToCheck, 3)
                        Exit For
                    End If
                Next SecondsCounter
            End If
        End If
    Next CellToCheck

    If FirstCell Is Nothing Then
        Debug.Print "No FirstCell Found"
    Else
        Set myDayRange = .Range(FirstCell.Address & ":" & LastCell.Address)
        Debug.Print "The Range from " & Format(FirstCell, "hh:mm:ss") & " to " & Format(LastCell, "hh:mm:ss") & " is: "; myDayRange.Address
    End If

    End With
End Sub

Короче говоря, он форматирует входное значение как затем число и входные данные сравниваются с числовым значением c каждой ячейки в диапазоне (в пределах критериев For...Loop).

Если точное совпадение не найдено, оно проходит через - 7 до + 7 секунд времени ввода, чтобы найти ближайшее совпадение.

Я уверен, что это может быть уточнено, но из моего краткого тестирования я получил ожидаемый диапазон.

...