locked
Modify Script to Delete Entire Row?? RRS feed

  • Question

  • Hello all,

     

    So I found this macro online to delete duplicate entries in selected cells.

    Could someone help me to modify it so that it deletes the entire row that the duplicate was found on and shift all rows up? And also right now it kind works the opposite of how I want it where the duplicates that are "cleared" are from top to bottom. How do I reverse it to where it would keep the 1st occurrence from the top?

    For Example this is what I would like the final result to be:

    Before Run:

        A    |     B     

      1.2  |   45  

      4.5  |   20  

      1.2  |   44  

      4.5  |   19  

      9.9  |    1  

      1.2  |   44  

      1.2  |   43  

      ....

     

    After run (how I'd like it to be):

        A    |     B     

      1.2  |  45   

      4.5  |  20   

      9.9  |   1    

     

    After run (how it really is):

        A    |     B     

            |       

            |       

            |       

      4.5  |   19

      9.9  |    1 

             |      

      1.2  |   43

      ....

     

     

     

    Here is the Script:

                                                                                                                                                    

    Sub KillDupes()

    Dim rConstRange As Range, rFormRange As Range
    Dim rAllRange As Range, rCell As Range
    Dim iCount As Long
    Dim strAdd As String

        On Error Resume Next
        Set rAllRange = Selection

            If WorksheetFunction.CountA(rAllRange) < 2 Then
                MsgBox "You selection is not valid", vbInformation
                On Error GoTo 0
                Exit Sub
            End If

        Set rConstRange = rAllRange.SpecialCells(xlCellTypeConstants)
        Set rFormRange = rAllRange.SpecialCells(xlCellTypeFormulas)

        If Not rConstRange Is Nothing And Not rFormRange Is Nothing Then
            Set rAllRange = Union(rConstRange, rFormRange)
        ElseIf Not rConstRange Is Nothing Then
            Set rAllRange = rConstRange
        ElseIf Not rFormRange Is Nothing Then
            Set rAllRange = rFormRange
        Else
            MsgBox "You selection is not valid", vbInformation
            On Error GoTo 0
            Exit Sub
        End If

        Application.Calculation = xlCalculationManual

        For Each rCell In rAllRange
            strAdd = rCell.Address
            strAdd = rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Address
            If strAdd <> rCell.Address Then
                rCell.Clear
            End If
        Next rCell

        Application.Calculation = xlCalculationAutomatic
        On Error GoTo 0

    End Sub
                                                                                                                                                    

     

    If anyone could help it would be much appreciated.

     

    Thanks in advance,

    Matt


    Matt
    Friday, June 24, 2011 4:44 PM

Answers

  •   For Each rCell In rAllRange
        strAdd = rCell.Address
        strAdd = rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Address
        If strAdd <> rCell.Address Then
          rCell.EntireRow.Delete()
        End If
      Next rCell
    
    Something like that probably. I have no idea if that would work though.

    • Marked as answer by Calvin_Gao Friday, July 1, 2011 8:40 AM
    Friday, June 24, 2011 6:47 PM
  • This is a simple issue and can be done by recording a macro

    Assuming your Data range is fixed from A4 to B50. Run the macro below and you are done.

    Sub Macro1()
    '
    ' Macro1 Macro
    '

    '
        Range("A4:B50").Select
        ActiveSheet.Range("$A$4:$B$50").RemoveDuplicates Columns:=1, Header:=xlYes
    End Sub


    Ankur Chakravarty Hyderabad
    • Marked as answer by Calvin_Gao Friday, July 1, 2011 8:40 AM
    Saturday, June 25, 2011 4:27 PM
  • the code below will work, although it is a little long it is very effiecient especially if you are a lot of rows of data.  Is uses the following formula :

    '=SUMPRODUCT(--(A$1:A1=A2),--(B$1:B1=B2))

    Then applies an autofilter to get the rows you want and copies only the visible rows using specialcells method.

     

    Sub RemoveDuplicates()
    
    'code Puts the folowing formula in cell IV2
    'and copies it down the worksheet.
    'then keeps only rows where result are zer0
    '=SUMPRODUCT(--(A$1:A1=A2),--(B$1:B1=B2))
    
    'Add header row so autofilter works properly
    'Auto filter will repeat first row if it match criteria
    
    Set Sourcesht = ActiveSheet
    
    With Sourcesht
    
      'remove autofilter method
    
      .AutoFilterMode = False
      
      .Rows(1).Insert
      'put header into cell IV1
      .Range("IV1") = "HEADER"
    
      LastRow = .Range("A" & Rows.Count).End(xlUp).Row
      
      'don't run code if there are no rows of data
      If LastRow <> 1 Then
    
       .Range("IV2").Formula = "=SUMPRODUCT(--(A$1:A1=A2),--(B$1:B1=B2))"
       'Copy Formula down column IV
       .Range("IV2").Copy _
       Destination:=Range("IV2:IV" & LastRow)
      
      
       'add autofilter to column IV
       'filter for results = 0
       .Columns("IV:IV").AutoFilter
       .Columns("IV:IV").AutoFilter Field:=1, Criteria1:="0"
      
       'use special cells method to select only visible rows
       'don't include added header row
       Set VisibleRows = .Rows("2:" & LastRow) _
         .SpecialCells(xlCellTypeVisible)
      
       'add new worksheet to put results
       Set NewSht = Sheets.Add(before:=Sheets(1))
       'change tab name
       NewSht.Name = "Non Duplicates"
      
       'copy rows into new shet
       VisibleRows.Copy _
         Destination:=NewSht.Rows(1)
      
       'remove autofilter method
       .AutoFilterMode = False
      End If
       
      'remove header row
      .Rows(1).Delete
    End With
    End Sub
    

     


    jdweng
    • Marked as answer by Calvin_Gao Friday, July 1, 2011 8:39 AM
    Sunday, June 26, 2011 7:51 AM

All replies

  •   For Each rCell In rAllRange
        strAdd = rCell.Address
        strAdd = rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Address
        If strAdd <> rCell.Address Then
          rCell.EntireRow.Delete()
        End If
      Next rCell
    
    Something like that probably. I have no idea if that would work though.

    • Marked as answer by Calvin_Gao Friday, July 1, 2011 8:40 AM
    Friday, June 24, 2011 6:47 PM
  • This is a simple issue and can be done by recording a macro

    Assuming your Data range is fixed from A4 to B50. Run the macro below and you are done.

    Sub Macro1()
    '
    ' Macro1 Macro
    '

    '
        Range("A4:B50").Select
        ActiveSheet.Range("$A$4:$B$50").RemoveDuplicates Columns:=1, Header:=xlYes
    End Sub


    Ankur Chakravarty Hyderabad
    • Marked as answer by Calvin_Gao Friday, July 1, 2011 8:40 AM
    Saturday, June 25, 2011 4:27 PM
  • the code below will work, although it is a little long it is very effiecient especially if you are a lot of rows of data.  Is uses the following formula :

    '=SUMPRODUCT(--(A$1:A1=A2),--(B$1:B1=B2))

    Then applies an autofilter to get the rows you want and copies only the visible rows using specialcells method.

     

    Sub RemoveDuplicates()
    
    'code Puts the folowing formula in cell IV2
    'and copies it down the worksheet.
    'then keeps only rows where result are zer0
    '=SUMPRODUCT(--(A$1:A1=A2),--(B$1:B1=B2))
    
    'Add header row so autofilter works properly
    'Auto filter will repeat first row if it match criteria
    
    Set Sourcesht = ActiveSheet
    
    With Sourcesht
    
      'remove autofilter method
    
      .AutoFilterMode = False
      
      .Rows(1).Insert
      'put header into cell IV1
      .Range("IV1") = "HEADER"
    
      LastRow = .Range("A" & Rows.Count).End(xlUp).Row
      
      'don't run code if there are no rows of data
      If LastRow <> 1 Then
    
       .Range("IV2").Formula = "=SUMPRODUCT(--(A$1:A1=A2),--(B$1:B1=B2))"
       'Copy Formula down column IV
       .Range("IV2").Copy _
       Destination:=Range("IV2:IV" & LastRow)
      
      
       'add autofilter to column IV
       'filter for results = 0
       .Columns("IV:IV").AutoFilter
       .Columns("IV:IV").AutoFilter Field:=1, Criteria1:="0"
      
       'use special cells method to select only visible rows
       'don't include added header row
       Set VisibleRows = .Rows("2:" & LastRow) _
         .SpecialCells(xlCellTypeVisible)
      
       'add new worksheet to put results
       Set NewSht = Sheets.Add(before:=Sheets(1))
       'change tab name
       NewSht.Name = "Non Duplicates"
      
       'copy rows into new shet
       VisibleRows.Copy _
         Destination:=NewSht.Rows(1)
      
       'remove autofilter method
       .AutoFilterMode = False
      End If
       
      'remove header row
      .Rows(1).Delete
    End With
    End Sub
    

     


    jdweng
    • Marked as answer by Calvin_Gao Friday, July 1, 2011 8:39 AM
    Sunday, June 26, 2011 7:51 AM
  • Hey guys,

     

    Thanks for the replies. I will give all yours tries and see which one works for what I need to do.

     

    Thanks again,

    Matt

     

     

     

    .


    Matt
    Monday, June 27, 2011 3:03 PM