Question

我有一个电子表格，其中包含记录号，帐户，开始日期和完成日期。我正在尝试计算结束日期后14天内重新测试的次数。我已经能够编写代码以获取日期的不同出现，但是我在计数方面遇到了麻烦。

[ Original filtered dataset[1]

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上的结果之后：

一个日期的Excel VBA计数时间在上一个日期的2周内

1 个答案: