Excel VBA Count Times дата встречается в течение 2 недель после предыдущей даты

Question

У меня есть электронная таблица, содержащая номер записи, учетную запись, дату начала и окончания.Я пытаюсь подсчитать, сколько раз повторное тестирование проводилось в течение 14 дней с даты окончания.Я был в состоянии написать код, чтобы получить различные вхождения дат, но у меня возникли проблемы с подсчетами.

[

Sub DistinctObs()


    Dim ws As Worksheet
    Dim nws As Worksheet
    Dim lRow As Long, i As Long, j As Long
    Dim col As New Collection
    Dim Itm
    Dim cField As String

    Const deLim As String = "#"


    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "DistinctObs"

    Set ws = ThisWorkbook.Sheets(1)
    Set nws = ThisWorkbook.Sheets("DistinctObs")

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 2 To lRow
            cField = .Range("A" & i).Value & deLim & _
                     .Range("B" & i).Value & deLim & _
                     .Range("G" & i).Value & deLim & _
                     .Range("I" & i).Value

            On Error Resume Next
            col.Add cField, CStr(cField)
            On Error GoTo 0
        Next i

        i = 2

        .Range("A1:B1").Copy nws.Range("A1")
        .Range("G1").Copy nws.Range("C1")
        .Range("I1").Copy nws.Range("D1")
         nws.Range("E1").Value = "Count"


        For Each Itm In col
            nws.Range("A" & i).Value = Split(Itm, deLim)(0)
            nws.Range("B" & i).Value = Split(Itm, deLim)(1)
            nws.Range("C" & i).Value = Split(Itm, deLim)(2)
            nws.Range("D" & i).Value = Split(Itm, deLim)(3)




            For j = 2 To lRow
                cField = .Range("A" & j).Value & deLim & _
                         .Range("B" & j).Value & deLim & _
                         .Range("G" & j).Value & deLim & _
                         .Range("I" & j).Value

                If Itm = cField Then nCount = nCount + 1
            Next
            nws.Range("E1" & i).Value = nCount

            i = i + 1
            nCount = 0
        Next Itm
    End With
End Sub

Этот код приводит к этому списку отфильтрованных данных

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

Answer 1

Хорошо, терпите меня, это было немного сложно.Вот код, который я использовал.У меня были выборочные данные в Sheet1, а таблица назначения была в `Sheet2.

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

Option Explicit
Sub Test()

Dim i As Long, j As Long, recordnumber As Long
Dim sht1 As Worksheet, sht2 As Worksheet
Dim lastdate As Date

Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")

j = 2

For i = 2 To sht1.Cells(sht1.Rows.Count, 1).End(xlUp).Row

    If i = 2 Then
       sht2.Range(sht2.Cells(j, 1), sht2.Cells(j, 4)).Value = _
       sht1.Range(sht1.Cells(i, 1), sht1.Cells(i, 4)).Value
       recordnumber = sht2.Cells(j, 1).Value
       lastdate = sht2.Cells(j, 4).Value
    End If

    If i > 2 Then

        'make a new line for new record
        If sht1.Cells(i, 1).Value > recordnumber Then

            j = j + 1
            sht2.Range(sht2.Cells(j, 1), sht2.Cells(j, 4)).Value = _
            sht1.Range(sht1.Cells(i, 1), sht1.Cells(i, 4)).Value
            recordnumber = sht2.Cells(j, 1).Value
            lastdate = sht2.Cells(j, 4).Value

        'increase retest count
        ElseIf sht1.Cells(i, 1).Value = sht2.Cells(j, 1).Value And _
               sht1.Cells(i, 4).Value - sht2.Cells(j, 4).Value > 0 And _
               sht1.Cells(i, 4).Value - sht2.Cells(j, 4).Value < 14 And _
               sht1.Cells(i, 4).Value <> lastdate Then

            sht2.Cells(j, 5).Value = sht2.Cells(j, 5).Value + 1
            lastdate = sht1.Cells(i, 4).Value

        'make new line for same record, new date 14 days out
        ElseIf sht1.Cells(i, 1).Value = sht2.Cells(j, 1).Value And _
               sht1.Cells(i, 4).Value - sht2.Cells(j, 4).Value > 14 Then

            j = j + 1
            sht2.Range(sht2.Cells(j, 1), sht2.Cells(j, 4)).Value = _
            sht1.Range(sht1.Cells(i, 1), sht1.Cells(i, 4)).Value
            recordnumber = sht2.Cells(j, 1).Value
            lastdate = sht2.Cells(j, 4).Value

        End If
    End If

Next i

End Sub

Пример данных:

После результата на Sheet2: