Find duplicates based on criteria in two columns and copy to a new sheet

[Kindrex]

Hi all,

I really need some help with this one, I have done some research online but struggling to find anything for what I need.

In a sheet called "Data" I have some staff IDs in column H, with assessment results ("Pass","Fail") in column Z. I need to be able to track those staff IDs that have more than one fail.

What I need is a code that will run when I hit a button that will look find these duplicate staff ids with fails and copy the results to a new sheet called "Repeats". There could be multiple results per staff id

Ideally I would want the values in columns F, G, H, Z, AA, AB, AL, AM to be copied rather than the entire rows but it is not essential.

Thank you in advance.

 

[MickG]

Try this for results on sheet3.

[COLOR="Navy"]Sub[/COLOR] MG27Jul24
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray1(), c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oHds()
[COLOR="Navy"]With[/COLOR] Sheets("Data")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("F1", .Range("F" & Rows.Count).End(xlUp)).Resize(, 34)
    [COLOR="Navy"]End[/COLOR] With
ReDim ray(1 To Rng.Count, 1 To 8)
c = 1
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Columns(1).Cells

[COLOR="Navy"]If[/COLOR] Dn.Offset(, 20).Value = "Fail" [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Offset(, 2).Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Offset(, 2).Value, Nothing
    [COLOR="Navy"]Else[/COLOR]
       c = c + 1
       oHds = Application.Index(Rng(1).Resize(, 34), 0, Array(1, 2, 3, 21, 22, 23, 33, 34))
       Ray1 = Application.Index(Dn.Resize(, 34), 0, Array(1, 2, 3, 21, 22, 23, 33, 34))
        [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray1)
            ray(1, n) = oHds(n)
            ray(c, n) = Ray1(n)
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Sheets("Sheet3").Range("A1").Resize(c, 8)
 .Value = ray
 .Borders.Weight = 2
 .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
MsgBox "End"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick