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

xjpx

New Member
Joined
Jan 3, 2022
Messages
25
Office Version
  1. 365
Platform
  1. Windows
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.
1652403683543.png

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

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

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!
 
Correct it:
Old:
Code:
r = r & "," & cell.Row - 1
New:
Code:
r = dic(cell.Value) & "," & cell.Row - 1

Now it should works:
VBA Code:
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
ABCDEFGHIJKLMNOPQRS
3No.Serial No.Equip Descrip.Current Location/Date InstalledDateFault Symtom of Train / ComponentDT No.Fault CausedRepair DetailsDateFault Symtom of Train / ComponentDT No.Fault CausedRepair DetailsDateFault Symtom of Train / ComponentDT No.Fault CausedRepair Details
Eqp Changeout Tracking
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Forum statistics

Threads
1,213,495
Messages
6,113,992
Members
448,538
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top