Consulting

Results 1 to 4 of 4

Thread: VBA help to compare 2 sheets and pick out duplicates

  1. #1

    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

  2. #2
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    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

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

  4. #4
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    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
    マナ

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •