How to use a loop function to count each occurrence of a unique value based on another column and determine earliest date for each unique value?

[allicat44]

I'm new-ish to VBA and have been able to do some simple coding but I've been having a hard time with my new, more complex task. My overall goal is to identify the number/percentage of samples that are collected within 12 hours and 24 hours of the first sample collected for each unique manufacturing code. I have been able to identify and pull each unique manufacturing code (B-Code) to column L and I'm hoping to be able to loop the code so that it determines the percentage of samples collected within 12 and 24 hours for each unique manufacturing code. I'm imagining this being done in steps-

1. Count and hold the number of samples for each manufacturing code (B-Code).
2. Determine the first sample of each B-Code and hold the time.
3. Count the number of samples that are collected 12 hours after the first sample identified in #2 for each B-Code and get the percentage.
4. Count the number of samples that are collected 24 hours after the first sample identified in #2 for each B-Code and get the percentage.
5. Loop

I'm running into a few issues with my current code so far- printing the value from #1 to my very last row instead of the corresponding row and returning a date for blank cells as the earliest sample for #2, even though I've used a worksheetfunction.minif function.



Attached is a picture of the code I have so far for counting. My image of the file I have is too large to attach, but column 1 has every time that the unique value in column 12 appears. I'm trying to count the number of times that the value in column 12 appears in column 1. Then establish the earliest time it appears, excluding blanks, in column 5. Then count the number of time of samples from that unique manufacturing code occur within 12 and 24 hours of the first time. Thank you!!

 

[BSALV]

it's easy with a pivottable or in your 365 with formulas.

 

[BSALV]

Map1
	A	B	C	D	E	F	G	H	I	J	K	L	M													Z	AA	AB	AC	AD
1	12/04/2022 11:58											a															a	12/04/2022 11:57	2	2
2	12/04/2022 11:59											a															b	12/04/2022 11:59	3	3
3	12/04/2022 12:00											b															c	12/04/2022 12:02	6	6
4	12/04/2022 12:01											b															d	12/04/2022 12:08	6	6
5	12/04/2022 12:02											b
6	12/04/2022 12:03											c
7	12/04/2022 12:04											c
8	12/04/2022 12:05											c
9	12/04/2022 12:06											c
10	12/04/2022 12:07											c
11	12/04/2022 12:08											c
12	12/04/2022 12:09											d
13	12/04/2022 12:10											d
14	12/04/2022 12:11											d
15	12/04/2022 12:12											d
16	12/04/2022 12:13											d
17	12/04/2022 12:14											d
18
19
20
Blad1

Cell Formulas
Range	Formula
A1	A1	=NOW()
A2:A17	A2	=+A1+TIME(0,1,0)

for a new-ish, perhaps too complex, because everything is done in arrays (much quicker)

Sub MyCounters()
     Dim Result()
     With ActiveSheet
          arr = .Range("A1").CurrentRegion.Resize(, 12).Value2  'read a contigious block of data around A1 (number of rows unknown) and 12 columns width (because your B-code in in col 12)

          ReDim Result(1 To UBound(arr), 1 To 4)
     'in result we store
     'column 1 = B-code
     'column 2 = earliest time
     'column 3 = count 12 hours
     'column 4 = count 24 hours

          ptr = 0
          For i = 1 To UBound(arr)                              'loop through your data
               bcode = arr(i, 12)
               If bcode <> "" Then
                    r = Application.Match(bcode, Application.Index(Result, 0, 1), 0)     'check if code already exists in 1st column RESULT
                    If Not IsNumeric(r) Then                    'code doesn't exist,
                         ptr = ptr + 1                          ' so increment pointer
                         r = ptr                                ' r=pointer
                         Result(r, 1) = bcode
                         Result(r, 2) = arr(i, 1)               'earliest time
                    End If
                    If WorksheetFunction.Median(arr(i, 1), Result(r, 2), Result(r, 2) + 0.5) = arr(i, 1) Then Result(r, 3) = Result(r, 3) + 1     'within the 12 hours-period (between earliest time and earliest + 12 hours (=0.5)
                    If WorksheetFunction.Median(arr(i, 1), Result(r, 2), Result(r, 2) + 1) = arr(i, 1) Then Result(r, 4) = Result(r, 4) + 1     'within the 12 hours-period
               End If
          Next

          .Range("AA1").Resize(ptr, 4).Value2 = Result
     End With
End Sub

 

[allicat44]

Thank you for your quick response! I've been getting thrown a few errors while trying this and have been able to solve most of them except for Error 9: Subscript out of range. When I try to debug it highlights the If WorksheetFunction.Median(arr.. line. When I hover over the arr(i, 1) it correctly shows that it's the b-code, but when I hover over the Result (r, 2) part I get: "Result(r,5) = <Subscript out of range>.

I'm not sure what's impact this, maybe because the dates being referenced aren't in chronological order or because there's blank cells within the column, so I'm attaching my code. I do have the part of the code that I'm getting the error referencing the column that actually has the dates.

Material Tracking Data FY23.xlsm
	A	B	C	D	E	F					K	L	M	N	O	P
1	B Code	Product Code Code	Sample	BO Date + Time	BK Date + Time	Release Date + Time
2	B1109122	2000015	091B1001	4/2/22 2:21 PM	4/2/22 2:38 PM	4/4/22 10:00					91	B1109122	33.43333333	43.36666667	62	2000015.00
3	B1109122	2000015	091B1007	4/2/22 4:31 PM	4/2/22 5:27 PM	4/4/22 10:00					91	B1209122	17.48333333	35.58333333	62	2000015
4	B1109122	2000015	091B1014	4/2/22 10:15 PM	4/3/22 12:34 AM	4/4/22 10:00					92	B1109222	13.88333333	45.08333333	62	2000015
5	B1109122	2000015	091B1020	4/2/22 9:49 PM	4/2/22 10:30 PM	4/4/22 10:00					92	B1209222	37.68333333	53.71666667	62	2000015
6	B1209122	2000015	091B1021	4/2/22 9:24 PM	4/2/22 10:25 PM	4/4/22 10:00					93	B1109322	31.01666667	40.33333333	62	2000015
7	B1209122	2000015	091B1028	4/3/22 4:10 AM	4/3/22 8:48 AM	4/4/22 10:00					93	B1209322	38.96666667	51.3	62	2000017
8	B1209122	2000015	091B1035	4/3/22 3:31 AM	4/3/22 8:55 AM	4/4/22 10:00					94	B1109422	54.91666667	78.25	62	2000017
9	B1209122	2000015	091B1042	4/3/22 1:43 PM	4/3/22 4:31 PM	4/4/22 10:00					94	B1209422	31.48333333	36.71666667	62	2000017
10	B1209122	2000015	091B1048	4/3/22 1:04 PM	4/3/22 1:50 PM	4/4/22 10:00					95	B1209522	116.4	125.1166667	62	2000015
11	B1209122	2000015	091B1055	4/3/22 12:29 PM	4/3/22 1:05 PM	4/4/22 10:00					96	B1109622	74.4	94.23333333	62	2000015
12	B1209122	2000015	091B1062	4/3/22 11:57 AM		4/4/22 10:00					96	B1209622	62.1	75.33333333	62	2000015
13	B1109222	2000015	092B1001	4/3/22 11:53 AM	4/3/22 12:55 PM	4/5/22 10:00					97	B1109722	47.76666667	61.13333333	62	2000015
14	B1109222	2000015	092B1007	4/3/22 7:55 PM	4/3/22 9:15 PM	4/5/22 10:00					97	B1209722	36.33333333	47.6	62	2000015
15	B1109222	2000015	092B1014	4/3/22 7:10 PM	4/3/22 7:20 PM	4/5/22 10:00					98	B1109822	22.81666667	37.63333333	62	2000015
16	B1109222	2000015	092B1020	4/3/22 7:03 PM	4/3/22 7:55 PM	4/5/22 10:00					98	B1209822	32.15	51.75	62	2000015
17	B1109222	2000015	092B1027	4/4/22 5:30 AM	4/4/22 7:47 AM	4/5/22 10:00					99	B1109922	47.26666667	65	62	2000015
18	B1109222	2000015	092B1033	4/4/22 4:44 AM	4/4/22 7:57 AM	4/5/22 10:00					99	B1209922	NO VALUE	NO VALUE	62	2000015
19	B1109222	2000015	092B1039	4/4/22 12:47 AM	4/4/22 2:20 AM	4/5/22 10:00					100	B1110022	NO VALUE	NO VALUE	62	2000015
20	B1109222	2000015	092B1046	4/4/22 12:07 AM	4/4/22 2:35 AM	4/5/22 10:00					100	B1210022	NO VALUE	NO VALUE	62	2000015
21	B1109222	2000015	092B1052	4/4/22 4:05 AM	4/4/22 8:07 PM	4/5/22 10:00					101	B1110122	NO VALUE	NO VALUE	62	2000015
22	B1209222	2000015	092B1053	4/4/22 4:00 AM	4/4/22 8:19 PM	4/6/22 10:00					101	B1210122	NO VALUE	NO VALUE	62	2000015
23	B1209222	2000015	092B1060	4/4/22 3:11 AM	4/4/22 4:17 AM	4/6/22 10:00										0
24	B1209222	2000015	092B1066	4/4/22 10:55 AM	4/4/22 12:39 PM	4/6/22 10:00
25	B1209222	2000015	092B1073	4/4/22 10:20 AM	4/4/22 12:47 PM	4/6/22 10:00
26	B1209222	2000015	092B1080	4/4/22 3:50 PM	4/4/22 4:29 PM	4/6/22 10:00
27	B1209222	2000015	092B1086	4/4/22 3:16 PM	4/4/22 4:59 PM	4/6/22 10:00
28	B1209222	2000015	092B1093	4/4/22 2:14 PM	4/4/22 2:37 PM	4/6/22 10:00
29	B1209222	2000015	092B1099	4/4/22 6:02 PM	4/4/22 6:57 PM	4/6/22 10:00
30	B1209222	2000015	092B1106	4/4/22 5:32 PM	4/4/22 6:13 PM	4/6/22 10:00
31	B1109322	2000015	093B1001	4/4/22 5:22 PM	4/4/22 5:40 PM	4/6/22 10:00
32	B1109322	2000015	093B1008	4/4/22 7:59 PM	4/4/22 8:41 PM	4/6/22 10:00
33	B1109322	2000015	093B1015	4/5/22 2:31 AM	4/5/22 2:59 AM	4/6/22 10:00
34	B1109322	2000015	093B1022	4/5/22 12:45 AM	4/5/22 1:25 AM	4/6/22 10:00
35	B1209322	2000017	093B1023			4/7/22 10:00
36	B1209322	2000017	093B1029	4/5/22 6:01 AM	4/5/22 6:42 AM	4/7/22 10:00
BackerData

Map1
	A	B	C	D	E	F	G	H	I	J	K	L	M													Z	AA	AB	AC	AD
1	12/04/2022 11:58											a															a	12/04/2022 11:57	2	2
2	12/04/2022 11:59											a															b	12/04/2022 11:59	3	3
3	12/04/2022 12:00											b															c	12/04/2022 12:02	6	6
4	12/04/2022 12:01											b															d	12/04/2022 12:08	6	6
5	12/04/2022 12:02											b
6	12/04/2022 12:03											c
7	12/04/2022 12:04											c
8	12/04/2022 12:05											c
9	12/04/2022 12:06											c
10	12/04/2022 12:07											c
11	12/04/2022 12:08											c
12	12/04/2022 12:09											d
13	12/04/2022 12:10											d
14	12/04/2022 12:11											d
15	12/04/2022 12:12											d
16	12/04/2022 12:13											d
17	12/04/2022 12:14											d
18
19
20
Blad1

Cell Formulas
Range	Formula
A1	A1	=NOW()
A2:A17	A2	=+A1+TIME(0,1,0)

for a new-ish, perhaps too complex, because everything is done in arrays (much quicker)

Sub MyCounters()
     Dim Result()
     With ActiveSheet
          arr = .Range("A1").CurrentRegion.Resize(, 12).Value2  'read a contigious block of data around A1 (number of rows unknown) and 12 columns width (because your B-code in in col 12)

          ReDim Result(1 To UBound(arr), 1 To 4)
     'in result we store
     'column 1 = B-code
     'column 2 = earliest time
     'column 3 = count 12 hours
     'column 4 = count 24 hours

          ptr = 0
          For i = 1 To UBound(arr)                              'loop through your data
               bcode = arr(i, 12)
               If bcode <> "" Then
                    r = Application.Match(bcode, Application.Index(Result, 0, 1), 0)     'check if code already exists in 1st column RESULT
                    If Not IsNumeric(r) Then                    'code doesn't exist,
                         ptr = ptr + 1                          ' so increment pointer
                         r = ptr                                ' r=pointer
                         Result(r, 1) = bcode
                         Result(r, 2) = arr(i, 1)               'earliest time
                    End If
                    If WorksheetFunction.Median(arr(i, 1), Result(r, 2), Result(r, 2) + 0.5) = arr(i, 1) Then Result(r, 3) = Result(r, 3) + 1     'within the 12 hours-period (between earliest time and earliest + 12 hours (=0.5)
                    If WorksheetFunction.Median(arr(i, 1), Result(r, 2), Result(r, 2) + 1) = arr(i, 1) Then Result(r, 4) = Result(r, 4) + 1     'within the 12 hours-period
               End If
          Next

          .Range("AA1").Resize(ptr, 4).Value2 = Result
     End With
End Sub

 

[allicat44]

Sub BackerSampleCounter()

Worksheets("BackerData").Activate

Dim Result() As String

With ActiveSheet

arr = .Range("A1").CurrentRegion.Resize(, 8).Value2

ReDim Result(1 To UBound(arr), 1 To 4)

ptr = 0

For y = 1 To UBound(arr)

BackerBCode = arr(y, 1)

If BackerBCode <> "" Then

r = Application.Match(BackerBCode, Application.Index(Result, 0, 1), 0)

If Not IsNumeric(r) Then

ptr = ptr + 1

r = ptr

Result(r, 1) = BackerBCode

Result(r, 2) = arr(y, 1)

End If

If WorksheetFunction.Median(arr(y, 1), Result(r, 5), Result(r, 5) + 0.5) = arr(y, 1) Then Result(r, 3) = Result(r, 3) + 1

If WorksheetFunction.Median(arr(y, 1), Result(r, 5), Result(r, 5) + 1) = arr(I, 1) Then Result(r, 4) = Result(r, 4) + 1

End If

Next

.Range("Q2").Resize(ptr, 4).Value2 = Result

End With

End Sub

 

[BSALV]

Result is the array where the macro prepares the output and that one is x rows by 4 columns, because of the ReDim Result(1 To UBound(arr), 1 To 4), so assigning a value to the 5th column is an error.
Each of the 4 columns of "Result" stores a value,
1 was the B-code (here A-column, so that's okay with your "Backercode",
2 was the earliest time, but i don't know which column of your table you're choosing for that one, so Result(r, 2) = arr(y, 1), that 1 must be a 4, 5 or 6 (column D, E or F). So Result(r,5) that 5 has to remain 2

If there is no time given like in row 35, that causes no problem i think.
Does this help or still errors ?

 

[allicat44]

I am now getting a 'Run-Time Error '1004': Unable to get the median property of the WorksheetFunction class'.

I've been playing around with the code, and I'm not sure if this error is because the If WorksheetFunction.Median part is trying to find the average of time and string values, if I'm reading the code correctly.

 

[BSALV]

allicate44.xlsm
important problems/errors
* the array Result can't be declared as string, because it also contains numbers
declaring variables isn't an obligation, it's an option (see "Option Explicit")
* start reading at the 2nd line, because the first is the headerrow
* if the earliest timestamp doesn't exist and later it does, use that timestamp as earliest.
BUT : is it allowed to use this records to count in the 12 and 24 hours period ??? (now it does)
* the column for the earliest time is fixed by the variable "mycolumn" to the value 4 (the BO date)

Sub BackerSampleCounter()

     Worksheets("BackerData").Activate

     Dim Result() As Variant                                    'NOT AS STRING, only the 1st column is string, the 2nd is a timestamp (=double) and 3-4 are integers !!!
     mycolumn = 4                                               'during the whole macro, column 4 of Arr is the column with your timestamp, BO Date + time  as "earliest moment"

     With ActiveSheet

          arr = .Range("A1").CurrentRegion.Resize(, 8).Value2   'read your data (with datevalues, so date2) to an array, x rows by 8 columns

          ReDim Result(1 To UBound(arr), 1 To 4)                'redimension your result-array, also x rows but only 4 columns

          ptr = 0                                               'this is the pointer to know the last written row in Result during this macro, so now it's 0

          For y = 2 To UBound(arr)                              'loop through the data of arr, MY ERROR !!!! START AT THE 2ND ROW, THE 1ST IS THE HEADERROW

               BackerBCode = arr(y, 1)                          '1st column, so your Backercode

               If BackerBCode <> "" Then                        'the backercode is not empty

                    r = Application.Match(BackerBCode, Application.Index(Result, 0, 1), 0)     'is that backercode already known in the 1st column of Result ?

                    If Not IsNumeric(r) Then                    'NO

                         ptr = ptr + 1                          'the linenumber in Result that now 'll be used (thus increment 1)

                         r = ptr                                'r was not numeric 2 lines ago, so r is that new line further in this macro

                         Result(r, 1) = BackerBCode             'add backercode as 1st element in that new line of Result

                         Result(r, 2) = arr(y, mycolumn)        'add BO Date + time (4th column of Arr) as "earliest moment"

                    End If

                    If IsEmpty(Result(r, 2)) And Not IsEmpty(arr(y, mycolumn)) Then Result(r, 2) = arr(y, mycolumn)     'if the bakercode in a previous line didn't have a BO date and this one has, well that's the earliest time

                    If WorksheetFunction.Median(arr(y, mycolumn), Result(r, 2), Result(r, 2) + 0.5) = arr(y, mycolumn) Then Result(r, 3) = Result(r, 3) + 1     'if the timestamp of this record is between the earliest and earliest + 1/2 day then counter +1

                    If WorksheetFunction.Median(arr(y, mycolumn), Result(r, 2), Result(r, 2) + 1) = arr(y, mycolumn) Then Result(r, 4) = Result(r, 4) + 1     'ame for a whole day

               End If

          Next

          With .Range("Q2")                                     'this is the topleftcorner to write
               .Resize(1000, 4).ClearContents                   'erase previous data (oversized 1000 rows * 4 columns)
               .Resize(1000, 1).Offset(, 1).NumberFormat = "dd/mm/yy hh:mm"     'specify the numberformat to this format
               .Resize(ptr, 4).Value2 = Result                  'write the collected data in Result to the sheet (only the first used rows = ptr)
               .Resize(, 4).EntireColumn.AutoFit                'adjust columnwidth so that everything fits
          End With

     End With

End Sub