VBA help to compare 2 sheets and pick out duplicates

hi guys,

I'm looking for a bit of help. I've got 2 spreadsheets, the same spreadsheet but i need to compare the two. i need the code to pick out certain ones that have been highlighted in red and produce them on a third sheet ONLY if they're duplicates. I'm quite new to VBA and can mostly understand it but havent quite got the hang of writing it properly yet. I have underlined and put in bold the line I'm having trouble on.So far I have:

Sub HighlightRowIfRed()
Dim sh As Worksheet, ws As Worksheet
Dim LstRw As Long, Rng As Range
Dim rw As Long, cRng As Range
Application.DisplayAlerts = 0
Application.ScreenUpdating = 0


On Error Resume Next
Sheets("Duplicates").Delete
Set ws = Sheets.Add
With ws
.Move after:=Sheets(Sheets.Count)
.Name = "Duplicates"
.Range("A1") = "Header1"
Range("B1") = "Count"
For Each sh In Sheets
If sh.Name <> w.s.Name Then
With sh
LstRw = Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A10:G" & LstRw)
Rng.Copy ws.Rows(ws.Rows.Count, "A").End(xlUp).Offset(1)
End With
End If
Next sh


rw = .Cells(Rows.Count, "A").End(xlUp).Row
Set cRng("A10:G" & rw)
cRng.Offset(, 1) = "=COUNTIF($A$1:$A$" & rw & ",A2)"
.Range("B:B").AutoFilter Field:=1, Criteria:=">1"
cRng.Copy.Range ("A10")
.AutoFilterMode = 0
.Columns("A10:G").RemoveDuplicates Colums:=1, Header:=xlNo
.Range("C:C").ClearContents
End With
SetConditionalFromat


End Sub
Sub SetConditionalFormat()
Dim sh As Worksheet
Application.ScreenUpdating = 0
For Each sh In Sheets
If sh.Name <> "Duplicates" Then
With sh
With .Range("A:A").FormatConditions


.Delete
.Add Type:=xlExpression, Formula1:="=MATCH(A1,Duplicates!$A:$A,0)"
.Item(1).Intrior.ColorIndex = vbRed
End With
End With
End If
Next sh
Sheets(1).Select


End Sub

any help would be greatly appreciated!

thanks

Code:

---

Option Explicit


Sub test()
    Dim dic As Object
    Dim ws As Worksheet
    Dim c As Range
   
    Set dic = CreateObject("scripting.dictionary")
   
    For Each ws In Worksheets
        ws.Columns(1).Interior.ColorIndex = xlNone
        For Each c In ws.Range("a10", ws.Range("a10").End(xlDown))
            dic(c.Value) = dic(c.Value) + 1
        Next
    Next
   
    For Each ws In Worksheets
        For Each c In ws.Range("a10", ws.Range("a10").End(xlDown))
            If dic(c.Value) > 1 Then c.Interior.Color = vbRed
        Next
    Next
   
End Sub

---

thanks but how do i then transfer those duplicates in red to a new sheet?

Code:

---

Option Explicit

Sub test2()
    Dim dic As Object
    Dim wsDst As Worksheet
    Dim ws As Worksheet
    Dim c As Range
    Dim k
   
    Set dic = CreateObject("scripting.dictionary")
   
    Set wsDst = Worksheets("Duplicates")
    wsDst.UsedRange.Offset(1).ClearContents
   
    For Each ws In Worksheets
        If ws.Name <> wsDst.Name Then
            ws.Columns(1).Interior.ColorIndex = xlNone
            For Each c In ws.Range("a10", ws.Range("a10").End(xlDown))
                dic(c.Value) = dic(c.Value) + 1
            Next
        End If
    Next
   
    For Each k In dic
        If dic(k) = 1 Then dic.Remove k
    Next
   
    For Each ws In Worksheets
        If ws.Name <> wsDst.Name Then
            For Each c In ws.Range("a10", ws.Range("a10").End(xlDown))
                If dic.exists(c.Value) Then c.Interior.Color = vbRed
            Next
        End If
    Next
   
    wsDst.Range("a2").Resize(dic.Count).Value = Application.Transpose(dic.keys)

End Sub

---

マナ