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]

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

Hello @bebo021999 I wanna add another column into Sheet 'Eqp Changeout Tracking' (Column C). Its the name of the item of each 'Serial No.' (column B). This data is taken from 'Equip Descrip.' of Sheet 'Daily Reports' (Column K). As seen below, its only 1 added column beside 'Serial no.'. Could you help me with this please?

CBTC LRUs Changed-Out Data.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
3	No.	Serial No.	Equip Descrip.	Current Location/Date Installed	Date	Fault Symtom of Train / Component	DT No.	Fault Caused	Repair Details	Date	Fault Symtom of Train / Component	DT No.	Fault Caused	Repair Details	Date	Fault Symtom of Train / Component	DT No.	Fault Caused	Repair Details
Eqp Changeout Tracking