Find repeating numbers then copy certain cells of same row to another sheet

[xjpx]

Hi all, I am in need of some help. I am trying to loop through column 'N' to find for numbers that are repeated 3 times or more. Once found all these number, paste the numbers into Sheet 2 along with some other cells in the same rows. Below I have attached some images with more explanation to better elaborate.
Firstly, search column 'M', if it is 'OUT' data in column 'N' is taken into account if it is 'IN' data in column 'N' does not need to be counted. Next, loop through column 'N' and find numbers that are repeated more than 3 times. So for the image below, only number 7890 needs to be considered as repeating 3 times as it had 3 OUTs. Dont have to consider IN 7890, in this case 7890 appears 3 times.

Next, information from columns A, C, D, I and L also have to be copied into the other sheet, Sheet 2.

The final product is exactly as seen below in Sheet 2. Column A is just running numbers as more Numbers matches the conditions above.

Seems really confusing to me... I hope I have done a good job explaining. I have tried running some scripts but I have problems matching both conditions of OUT and >= 3 repeats.

Thanks!

 

[xjpx]

Hi, sorry for that, may be by chance, " key" declaration was deleted
try to add

Dim key

That fixed it! Now I ran into a Run-time error '9' : Subscript out of range for the line,

arr(k, i * 5 -1) = rng(s(i), 4) & "/" & rng(s(i), 3) & "/" & rng(s(i), 1)

Is this due to my month being fully caps in my data? I just realized that the sample data I provided have the month uncapitalized.

 

[bebo021999]

That fixed it! Now I ran into a Run-time error '9' : Subscript out of range for the line,

arr(k, i * 5 -1) = rng(s(i), 4) & "/" & rng(s(i), 3) & "/" & rng(s(i), 1)

Is this due to my month being fully caps in my data? I just realized that the sample data I provided have the month uncapitalized.

I don't think so.
I wished you could post a sheet screenshot of dummy data
(or attach it via google drive, may be? remember to delete sensitive data)

 

[xjpx]

I don't think so.
I wished you could post a sheet screenshot of dummy data
(or attach it via google drive, may be? remember to delete sensitive data)

Hi, I created more data I hope this helps. The other columns are redundant that's why I did not include it in my dummy data. My bad if that is the reason that caused the issue.

Test.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Year	Week	Month	Date	Stack	Part	Team	Team No.	Data 1	Type	Describe	Data 2	Action	Number	New Number
2	1999	1	JAN	6	401234	3CU-1AVB	LION	2	A	C	POWER	J	IN	123456	9875
3	1999	2	JAN	7	401828	300-9-000	TIGER	2	B	C	ELECTRIC	K	OUT	7890	7865
4	1999	2	FEB	8	401323	3CU12345	MOUSE	2	C	C	BATTERY	L	OUT	7890	7865
5	1999	2	FEB	15	401828	300-AAA-123	CAT	2	X	C	POWER	M	IN	12345	75321
6	1999	2	MAR	12	401814	3145OASP	CAR	1	E	C	ENERGY	N	OUT	123456	9875
7	2000	1	JAN	1	401821	3-ACU-456	LION	1	F	C	BATTERY	O	IN	7890	7865
8	2000	1	APR	2	401712	RBU-AAA-010	HOUSE	3	G	C	POWER	P	OUT	7890	7865
9	2000	3	MAY	17	401345	31455OA	LAND	2	B	C	ELECTRIC	Q	OUT	12345	75321
10	2000	4	MAY	22	401888	5679O0A	CAT	3	I	C	ENERGY	R	OUT	12345	75321
11	2000	1	JUN	1	401001	828146D	CAT	1	X	C	BATTERY	Z	OUT	12345	75321
12	2000	2	JUN	9	401222	488934ARU	LION	3	Y	C	POWER	HI	IN	36280	23722
13	2001	1	JAN	3	401999	ZXU-A-345	CAR	1	YU	C	ELECTRIC	RU	OUT	73032	56556
Sheet1

 

[bebo021999]

It still works for me. Its so weird!
I wonder, with this line:

lr = Cells(Rows.count, "A").End(xlUp).Row

witl lr (last row) is last row of column A, sheet 1
Is there any redundant data in column A sheet1, from end of table downwards?

 

[xjpx]

It still works for me. Its so weird!
I wonder, with this line:

lr = Cells(Rows.count, "A").End(xlUp).Row

witl lr (last row) is last row of column A, sheet 1
Is there any redundant data in column A sheet1, from end of table downwards?

Nope there is no redundant data in that column but I have many hidden columns in-between if that affects anything?

 

[bebo021999]

Nope there is no redundant data in that column but I have many hidden columns in-between if that affects anything?

The code works for column A-N only. Other columns, did not effect to the results.
Try to attach sample file via google drive (with un-sensitive data).

 

[xjpx]

The code works for column A-N only. Other columns, did not effect to the results.
Try to attach sample file via google drive (with un-sensitive data).

Okay I will attach a sample via gdrive. Will let you know tomorrow! Thanks!

 

[xjpx]

The code works for column A-N only. Other columns, did not effect to the results.
Try to attach sample file via google drive (with un-sensitive data).

@bebo021999 I have uploaded my sheet into google drive.

Mrexceltest.xlsm

drive.google.com

 

[bebo021999]

Correct it:
Old:

r = r & "," & cell.Row - 1

New:

r = dic(cell.Value) & "," & cell.Row - 1

Now it should works:

Option Explicit
Sub FindCondemn()
Dim lr&, i&, j&, k&, max&, count&, key
Dim rng, s, r As String, cell As Range, dic As Object, arr()
Set dic = CreateObject("Scripting.dictionary")
Worksheets("Daily Reports").Activate
lr = Cells(Rows.count, "A").End(xlUp).Row
rng = Range("A2:N" & lr).Value
    For Each cell In Range("N2:N" & lr)
        count = WorksheetFunction.CountIfs(Range("M2:M" & lr), "Changed Out", Range("N2:N" & lr), cell.Value) 'count "Changed Out"'s of specific number
        If count > max Then max = count ' get the maximum "Changed Out" within numbers
        If cell.Offset(, -1).Value = "Changed Out" And count > 2 Then 'loop through each number with "Changed Out">=3, then write "Serial No." and "Row Number" into dictionary
            If Not dic.exists(cell.Value) Then
                k = k + 1
                r = count & "," & cell.Row - 1
                dic.Add cell.Value, r
            Else
                r = dic(cell.Value) & "," & cell.Row - 1
                dic(cell.Value) = r
            End If
        End If
    Next
    k = 0
    ReDim arr(1 To dic.count, 1 To max * 5 + 1) ' create variable array
    
Worksheets("Eqp Changeout Tracking").Activate
    Range("A3:B3").Value = Array("No.", "Serial No.")
    For Each key In dic.keys
        k = k + 1
        s = Split(dic(key), ",")
        For j = 1 To max * 5 + 1
            arr(k, 1) = k
            arr(k, 2) = key
            For i = 1 To UBound(s)
                Range(Cells(3, i * 5 - 1), Cells(3, i * 5 + 1)).Value = Array("Date", "Fault Symtom of Train / Component", "Train No.")
                arr(k, i * 5 - 1) = rng(s(i), 4) & "/" & rng(s(i), 3) & "/" & rng(s(i), 1)
                arr(k, i * 5) = rng(s(i), 12)
                arr(k, i * 5 + 1) = rng(s(i), 9)
            Next
        Next
    Next
Range("A4").Resize(k, max * 5 + 1).Value = arr
End Sub

 

[xjpx]

Correct it:
Old:

r = r & "," & cell.Row - 1

New:

r = dic(cell.Value) & "," & cell.Row - 1

Now it should works:

Option Explicit
Sub FindCondemn()
Dim lr&, i&, j&, k&, max&, count&, key
Dim rng, s, r As String, cell As Range, dic As Object, arr()
Set dic = CreateObject("Scripting.dictionary")
Worksheets("Daily Reports").Activate
lr = Cells(Rows.count, "A").End(xlUp).Row
rng = Range("A2:N" & lr).Value
    For Each cell In Range("N2:N" & lr)
        count = WorksheetFunction.CountIfs(Range("M2:M" & lr), "Changed Out", Range("N2:N" & lr), cell.Value) 'count "Changed Out"'s of specific number
        If count > max Then max = count ' get the maximum "Changed Out" within numbers
        If cell.Offset(, -1).Value = "Changed Out" And count > 2 Then 'loop through each number with "Changed Out">=3, then write "Serial No." and "Row Number" into dictionary
            If Not dic.exists(cell.Value) Then
                k = k + 1
                r = count & "," & cell.Row - 1
                dic.Add cell.Value, r
            Else
                r = dic(cell.Value) & "," & cell.Row - 1
                dic(cell.Value) = r
            End If
        End If
    Next
    k = 0
    ReDim arr(1 To dic.count, 1 To max * 5 + 1) ' create variable array
   
Worksheets("Eqp Changeout Tracking").Activate
    Range("A3:B3").Value = Array("No.", "Serial No.")
    For Each key In dic.keys
        k = k + 1
        s = Split(dic(key), ",")
        For j = 1 To max * 5 + 1
            arr(k, 1) = k
            arr(k, 2) = key
            For i = 1 To UBound(s)
                Range(Cells(3, i * 5 - 1), Cells(3, i * 5 + 1)).Value = Array("Date", "Fault Symtom of Train / Component", "Train No.")
                arr(k, i * 5 - 1) = rng(s(i), 4) & "/" & rng(s(i), 3) & "/" & rng(s(i), 1)
                arr(k, i * 5) = rng(s(i), 12)
                arr(k, i * 5 + 1) = rng(s(i), 9)
            Next
        Next
    Next
Range("A4").Resize(k, max * 5 + 1).Value = arr
End Sub

Thanks so much for your help! I really appreciate this!