Identifying Duplicates then deleting them and cells either side

**raehippychick** · 04-08-2008, 07:41 AM

Hallo again lovely people!

As part of a (horribly large!) report I do each month I need to delete all duplicate reports, the unique reference for these is "Report number", which are in column B

My problem is once I have identified and deleted these from column B Using ASAP utilities) I also then want to delete the surrounding cells as I have columns A:J with data in that is used in assorted formulae around the rest of the report

So... could anyone help with a macro to find a duplicate in B8 (like ASAP does) then delete (shift cells up) Cells A8:J8

I have got as far as sorting by the report number and highlighting column B ready to delete the duplicates, so not very far then!

Very many thanks in advance
Rae

**royUK** · 04-08-2008, 08:02 AM

try this code, test it on a copy workbook.

Option Explicit

Sub removeDuplicates()
    Dim c      As Range
    Dim MyRange As Range
    Dim RngCheck As Range

    Set RngCheck = ActiveSheet.Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))
    For Each c In RngCheck
        If Application.WorksheetFunction.CountIf(RngCheck, c) > 1 Then
            If MyRange Is Nothing Then
                Set MyRange = c
            Else: Set MyRange = Union(MyRange, c)
            End If
        End If
    Next c
    '        Set MyRange = MyRange.Resize(0, 2)
    MyRange.Offset(0, 1).Delete
    MyRange.Delete

End Sub

**raehippychick** · 04-09-2008, 07:26 AM

Hallo Roy

Thanks for that, bits of it work but it seems to delete more cells than there are duplicates (I could be wrong) and also it deletes just the one cell e.g. B8, then moves the others left

What I'm after is to find all duplicates in column B (in my macro I've already sorted the data in columns A:J by report number in column B)

Then once the duplicates are identified to delete (or clear/empty would do as I can resort at the end) cells A:J on each line there is a duplicate found

I've tried to attach a cutdown and sanitised copy of my spreadsheet but can't get it small anough

but here is one with just the (fake) raw data in the correct rows/columns

As I say just clearing rather than deleting the cells would fine now I think about it

I have had a look at your code, but it is waaaay above my level (as you'll see if you look at my macros on the attached!!) so I couldn't figure out how to try and adapt it

Many thanks

Rae

**SOS** · 04-09-2008, 07:47 AM

Hi raehippychick,

I found the code below while searching for an answer to a similar problem. I tried it on your book2.xls and would appear to do what you want.

Sub RemoveDuplicatesGeneric()
'' Delete duplicate entries.

Dim rngAnswer As Range
Dim intCnt As Integer, intR As Integer, intI As Integer
Dim intRow As Integer, intCol As Integer

On Error Resume Next
Set rngAnswer = Application.InputBox("Please choose the first cell of the range to examine for duplicates.", Type:=8)
If rngAnswer Is Nothing Then Exit Sub
If rngAnswer.Count <> 1 Then Exit Sub
On Error GoTo 0

intRow = rngAnswer.End(xlDown).Row
intCol = rngAnswer.Column

Application.ScreenUpdating = False
intCnt = Application.WorksheetFunction.CountA(Range(rngAnswer, Cells(intRow, intCol)))

For intR = intRow To (intRow - intCnt + 2) Step -1
If Cells(intR, intCol).Value = Cells(intR, intCol).Offset(-1, 0).Value Then
Cells(intR, intCol).EntireRow.Delete
End If
Next intR

End Sub

Regards

**raehippychick** · 04-09-2008, 08:34 AM

So close!

I think the bit I want to change is this bit...

For intR = intRow To (intRow - intCnt + 2) Step -1
If Cells(intR, intCol).Value = Cells(intR, intCol).Offset(-1, 0).Value Then
Cells(intR, intCol).EntireRow.Delete

... so that it only deletes cells A:J in the particular row - at the moment it deletes the whole row, and in my actual report cells L1:AP220 have formulae and tables etc in them, so I can't afford to lose them!

If anyone could help me with this bit I'd be so very grateful

R

**SOS** · 04-09-2008, 09:17 AM

Hi raehippychick,

Changed the code and it should now do what you want. Perhaps not the most elegant of code but it works

Sub RemoveDuplicatesGeneric()
'' Delete duplicate entries.

Dim rngAnswer As Range
Dim intCnt As Integer, intR As Integer, intI As Integer
Dim intRow As Integer, intCol As Integer
Dim startCel, endCel

On Error Resume Next
Set rngAnswer = Application.InputBox("Please choose the first cell of the range to examine for duplicates.", Type:=8)
If rngAnswer Is Nothing Then Exit Sub
If rngAnswer.Count <> 1 Then Exit Sub
On Error GoTo 0

intRow = rngAnswer.End(xlDown).Row
intCol = rngAnswer.Column

Application.ScreenUpdating = False
intCnt = Application.WorksheetFunction.CountA(Range(rngAnswer, Cells(intRow, intCol)))

For intR = intRow To (intRow - intCnt + 2) Step -1
If Cells(intR, intCol).Value = Cells(intR, intCol).Offset(-1, 0).Value Then

x = Cells(intR, intCol).Address
startCel = Range(x).Offset(0, -1).Address
endCel = Range(x).Offset(0, 8).Address
Range(startCel, endCel).Delete
End If
Next intR

End Sub

Regards