Macro that Makes a list of all duplicates?

[tonywatsonhelp]

Hi Everyone,
Bit stuck on this,

In Sheet1 Columns B18:BY5000 I have a list of estate agents.
In Column F in have the company name,

I want to make a list in Sheet2 of all the duplicate Company names in Sheet1 Column F
I want to be able to delete or edit this list after so ideally if it could remove the data from Sheet1 that its putting in sheet 2 even better.

I would do this manually but I've got 52 states to get through so I need a macro>

Thanks

Tony

 

[Fishboy]

Re: Macro that Makes a list of all dupicates?

Hi Everyone,
Bit stuck on this,

In Sheet1 Columns B18:BY5000 I have a list of estate agents.
In Column F in have the company name,

I want to make a list in Sheet2 of all the duplicate Company names in Sheet1 Column F
I want to be able to delete or edit this list after so ideally if it could remove the data from Sheet1 that its putting in sheet 2 even better.

I would do this manually but I've got 52 states to get through so I need a macro>

Thanks

Tony

Hey again Tony!

If I have understood correctly then I think this will work. Test it out in a COPY of your workbook. You may need to amend the Sheet1 and Sheet2 references in my code to suit your data. My code assumes Sheet1 is the one with all the data and Sheet2 will be where we are putting the list. The code also assumes there is at least a header already in place in A1 of Sheet2.

The code will list the duplicates on Sheet2 then delete the duplicate row from Sheet1

Sub CheckAndDeleteDuplicates()
' Defines variables
Dim x As Long, cRange As Range, ws1 As Worksheet, ws2 As Worksheet


' Defines worksheets
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")


' Defines LastRow for both sheets
ws1LastRow = ws1.Cells(Rows.Count, "F").End(xlUp).Row
ws2LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1


    ' Set the check range as F1 to the last row of F on ws1
    Set cRange = ws1.Range("F1:F" & ws1LastRow)
        
        ' For each cell in the check range, working from the bottom upwards
        For x = cRange.Cells.Count To 1 Step -1
            With cRange.Cells(x)
                ' If a count of the cell value against cRange is more than 1 then...
                If Application.WorksheetFunction.CountIf(cRange, .Value) > 1 Then
                    ' Update the duplicate list on ws2 (assumes headers already in A1 of ws2)
                    ws2.Range("A" & ws2LastRow).Value = .Value
                        ' Increase ws2LastRow by 1 to account for the new row
                        ws2LastRow = ws2LastRow + 1
                            ' Delete the duplicate row from ws1
                            .EntireRow.Delete
                End If
            End With
        ' Check next cell in cRange
        Next x
End Sub

 

[Gary's Student]

Re: Macro that Makes a list of all dupicates?

This will place the list of duplicates in Sheet2 column F:

Sub FindDups()
    Dim r1 As Range, r2 As Range, N As Long
    Dim K As Long, wf As WorksheetFunction
    
    Set wf = Application.WorksheetFunction
    K = 1
    Set r2 = Sheets("Sheet2").Range("F:F")
    With Sheets("Sheet1")
        N = .Cells(Rows.Count, "F").End(xlUp).Row
        Set r1 = .Range("F1:F" & N)
        For i = 1 To N
            v = .Cells(i, "F").Value
            If wf.CountIf(r1, v) > 1 And wf.CountIf(r2, v) = 0 Then
                Sheets("Sheet2").Cells(K, "F").Value = v
                K = K + 1
            End If
        Next i
    End With
End Sub

 

[tonywatsonhelp]

Re: Macro that Makes a list of all dupicates?

Hi Fish Boy, Hi Gary,

Thanks to both of you for helping, unfortunately the results are not what I'm looking for, but its very close,
at the moment I'm only getting the duplicated cell, I need the data from Column B to Column BY of that line copied over?
also I need both / all the duplicates and the original one. so if theres one duplicate I need two Rows not just the duplicate row so I can compare them?

I've tried editing your code to do this but no luck so far, please help if you can

Thanks

Tony

 

[Fishboy]

Re: Macro that Makes a list of all dupicates?

Hi Fish Boy, Hi Gary,

Thanks to both of you for helping, unfortunately the results are not what I'm looking for, but its very close,
at the moment I'm only getting the duplicated cell, I need the data from Column B to Column BY of that line copied over?
also I need both / all the duplicates and the original one. so if theres one duplicate I need two Rows not just the duplicate row so I can compare them?

I've tried editing your code to do this but no luck so far, please help if you can

Thanks

Tony

Hmm, I'll have to go back to the drawing board and get back to you.

 

[tonywatsonhelp]

Re: Macro that Makes a list of all dupicates?

Thanks Fishboy

 

[tonywatsonhelp]

Re: Macro that Makes a list of all dupicates?

Oh I might have a way to make this simpler,
I can conditional format the column with the duplicates (F) to turn cell colour to RGB 255,0,0 this is great as it turns all the duplicate cells not just one repeats,
by doing this it shows up all the rows I want to copy range B to BY from, then all the macro would need to do is look down F for Cells with RGB 255 and copy the range B to BY to the new sheet?

 

[Fishboy]

Re: Macro that Makes a list of all dupicates?

Oh I might have a way to make this simpler,
I can conditional format the column with the duplicates (F) to turn cell colour to RGB 255,0,0 this is great as it turns all the duplicate cells not just one repeats,
by doing this it shows up all the rows I want to copy range B to BY from, then all the macro would need to do is look down F for Cells with RGB 255 and copy the range B to BY to the new sheet?

Heh, I wish I had seen this about an hour ago as I have been working on modifying my original code as below:

Sub CheckAndDeleteDuplicates()
' Defines variables
Dim x As Long, cRange As Range, Rng As Range, DelRange As Range, ws1 As Worksheet, ws2 As Worksheet, FindString As String


' Defines worksheets
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")


' Defines LastRow for both sheets
ws1LastRow = ws1.Cells(Rows.Count, "F").End(xlUp).Row
ws2LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    ' Set the check range as F1 to the last row of F on ws1
    Set cRange = ws1.Range("F1:F" & ws1LastRow)       
        ' For each cell in the check range, working from the bottom upwards
        For x = cRange.Cells.Count To 1 Step -1
            With cRange.Cells(x)
                ' If a count of the cell value against cRange is more than 1 then...
                If Application.WorksheetFunction.CountIf(cRange, .Value) > 1 Then
                    ' Set variable FindString as the cell value
                    FindString = .Value
                        ' Copy range B:BY of the "first" duplicate row to the first blank row on sheet 2
                        Range("B" & .Row, "BY" & .Row).Copy Destination:=ws2.Range("A" & ws2LastRow)
                            ' Delete the first duplicate row
                            Range("B" & .Row, "BY" & .Row).EntireRow.Delete
                                ' Increase ws2LastRow by 1 to account for the new data
                                ws2LastRow = ws2LastRow + 1
                                    ' With the check range
                                    With cRange
                                        ' Set Rng as the cell where FindString is found (the "second" duplicate)
                                        Set Rng = .Find(What:=FindString, _
                                                        After:=.Cells(1), _
                                                        LookIn:=xlValues, _
                                                        LookAt:=xlWhole, _
                                                        SearchOrder:=xlByRows, _
                                                        SearchDirection:=xlPrevious, _
                                                        MatchCase:=False)
                                            ' If Rng exists then
                                            If Not Rng Is Nothing Then
                                                ' Copy range B to BY of the corresponding row to the next blank row on sheet 2
                                                Range("B" & Rng.Row, "BY" & Rng.Row).Copy Destination:=ws2.Range("A" & ws2LastRow)
                                                    ' Delete the "second" duplicate row
                                                    Rng.EntireRow.Delete
                                                        ' Increase ws2LastRow by 1 to account for the new data
                                                        ws2LastRow = ws2LastRow + 1
                                            End If
                                    End With
                End If
            End With
        ' Check next cell in cRange
        Next x
End Sub

 

[tonywatsonhelp]

Re: Macro that Makes a list of all dupicates?

Hi Fishboy,
Thank you very much, It looks good from here won't get to test it till tomorrow but I'm sure it will be good, thank you so much once again for your time and your help