VBA First 5 rows for each ID change

[Stephen_IV]

Good morning,

I need to check the first 5 values for each ID change. If the first 5 rows are either (EA or MA) then it receives an X if not then blank. PS, I have about 150,000 rows. Thanks in advance!

First 5 of each group.xlsm
	A	B	C	D	E	F
1	111	EA			111	X
2	111	AB			222
3	111	EA			333	X
4	111	EA			444	X
5	111	EA			555
6	111	MA
7	111	AB
8	222	AB
9	222	EA
10	222	EA
11	222	EA
12	222	EA
13	222	EA
14	333	EA
15	333	EA
16	333	EA
17	333	EA
18	333	EA
19	333	EA
20	444	MA
21	444	MA
22	444	EA
23	444	EA
24	444	EA
25	444	EA
26	555	EA
27	555	AB
28	555	MA
29	555	MA
30	555	MA
31	555	AB
Sheet2

 

[Peter_SSs]

1. Why does 111 get an X when the second value is "AB"?

 

[Stephen_IV]

Sorry Peter_SSs you are right it should not have an X

 

[Peter_SSs]

Give this a try.

Sub EAMAx5_1()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, r As Long
  Dim Curr As Variant
  
  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 1 To UBound(a)
    If a(i, 1) <> Curr Then
      Curr = a(i, 1)
      For j = 0 To 4
        k = k - (a(i + j, 2) = "EA" Or a(i + j, 2) = "MA")
        If a(i + k, 1) <> Curr Then Exit For
      Next j
      r = r + 1
      b(r, 1) = Curr
      b(r, 2) = IIf(k = 5, "X", "")
      i = i + j - 1
      k = 0
    End If
  Next i
  Range("E1:D" & r).Value = b
End Sub

My sample data and results:

Stephen_IV.xlsm
	A	B	C	D	E
1	111	EA		111
2	111	AB		222
3	111	EA		333	X
4	111	EA		444	X
5	111	EA		555
6	111	MA
7	111	AB
8	222	AB
9	222	EA
10	222	EA
11	222	EA
12	222	EA
13	222	EA
14	333	EA
15	333	EA
16	333	EA
17	333	EA
18	333	EA
19	333	EA
20	444	MA
21	444	MA
22	444	EA
23	444	EA
24	444	EA
25	444	EA
26	555	EA
27	555	AB
28	555	MA
29	555	MA
30	555	MA
31	555	AB
Sheet1

 

[Stephen_IV]

Ahhhh yes!!! Thank you so much! Works perfect. Thanks again! I appreciate your help!!

 

[Alaa mg]

@Peter_SSs does the code design for office version 365 . I use 2019 and shows error subscript ou of range in this line

If a(i + k, 1) <> Curr Then

 

[Peter_SSs]

Ahhhh yes!!! Thank you so much! Works perfect. Thanks again! I appreciate your help!!

You're welcome. Thanks for the follow-up.

@Peter_SSs does the code design for office version 365 . I use 2019 and shows error subscript ou of range in this line

If a(i + k, 1) <> Curr Then

The code should work fine in 2019. There must be something different about your data or layout. Test the code with the exact data in post 1 or 4. You can copy/paste it to a blank worksheet using this icon at the top-left of the mini-sheet.