PDA

View Full Version : VBA help to compare 2 sheets and pick out duplicates



S.White89
03-23-2018, 04:51 AM
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

mana
03-24-2018, 03:19 AM
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

S.White89
03-31-2018, 04:49 AM
thanks but how do i then transfer those duplicates in red to a new sheet?

mana
03-31-2018, 07:03 AM
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


マナ