Solved

VB Macro to review and remove/delete duplicates within same column

Posted on 2013-01-31
9
479 Views
Last Modified: 2013-02-04
I'm looking for a VBA Macro that can go into one column, (Column E for example). The column will hold a 14 digit client record, when there is any change to a client record the 14th digit is changed (example 13013178910100 will become 13013178910102, and if altered again will become 13013178910104).  Is there a way to code the Macro so that it would keep the client record with the highest 14th digit and recognize the rest as duplicates and delete that row?
0
Comment
Question by:NYANBCNY32
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 3
  • 2
  • +1
9 Comments
 
LVL 6

Assisted Solution

by:nickinthooz
nickinthooz earned 25 total points
ID: 38842298
Function check_duplicates(column As String)
    Dim lastrow As Long
    Dim x As Long

    lastrow = Range(column & "65536").End(xlUp).Row
    For x = lastrow To 1 Step -1

        If Application.WorksheetFunction.CountIf(Range(column & "1:" & column & lastrow), Val(Range(column & x).Text)) > 1 Then
            check_duplicates = x  ' return row with a duplicate
            x = 1
        Else
         check_duplicates = 0
        End If
    Next x
End Function

Open in new window

0
 

Author Comment

by:NYANBCNY32
ID: 38842512
Thank you for the response, I did add this function, but it may be because I'm still very new to VBA, so maybe i'm missing something, but I'm not seeing where it's locating duplicates inside a single column and then deleting out each row from the page that holds a duplicate?
0
 
LVL 10

Assisted Solution

by:broro183
broro183 earned 175 total points
ID: 38845637
hi,

This code isn't thoroughly tested, but it seemed to work on the small data set that I tested it on.

Option Explicit

Sub Macro4()
'change if necessary
Const LetterOfColToCheck As String = "e"
Dim NumOfColToCheck As Long
Dim ws As Worksheet
Dim FilteredRngToDelete As Range
Dim LastCll As Range    'Last used cell
Dim LastRw As Long    'Last used row
Dim FirstBlankCol As Long

    'This code assumes that the sheet has headers in row 1 & that there is no filter on the sheet before the code is run.

    ' change the sheet if necessary
    Set ws = ThisWorkbook.ActiveSheet
    Set LastCll = LastCell(ws)

    With LastCll
        LastRw = .Row
        FirstBlankCol = .Column + 1
    End With


    With ws
        NumOfColToCheck = .Cells(1, LetterOfColToCheck).Column
        'add a column to list the original row order
        With .Cells(1, FirstBlankCol)
            .Value2 = "Original Row Order"
            With .Offset(1, 0).Resize(LastRw - 1, 1)
                .FormulaR1C1 = "=ROW(RC)"
                .Value2 = .Value2
            End With
        End With

        'sort by the 14 digit column
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=ws.Range(LetterOfColToCheck & "1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
                     xlSortTextAsNumbers
            End With
            .SetRange ws.Range("a1", ws.Cells(LastRw, FirstBlankCol))
            .Header = xlYes    'is this correct for your layout?
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        'add a helper column with a formula to compare the 14 digit codes
        With .Cells(1, FirstBlankCol + 1)
            .Value2 = "Helper Column to Filter & Delete"
            With .Offset(1, 0).Resize(LastRw - 1, 1)
                .FormulaR1C1 = "=IF(LEFT(RC" & NumOfColToCheck & ",13)=LEFT(R[1]C" & NumOfColToCheck & ",13),""delete"",""keep"")"
                .Value2 = .Value2
            End With
        End With

        'filter the sheet & delete the duplicates based on the results of the helper column
        ' (this assumes that the sheet has headers in row 1 & that there is no filter on the sheet before the code runs)
        With .Range("$a$1", .Cells(LastRw, FirstBlankCol + 1))
            .AutoFilter Field:=FirstBlankCol + 1, Criteria1:="delete"
            Set FilteredRngToDelete = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible)
            If Not FilteredRngToDelete Is Nothing Then
                FilteredRngToDelete.EntireRow.Delete
            End If
            .AutoFilter Field:=FirstBlankCol + 1
        End With

        'resort the rows to the original order
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=ws.Cells(1, FirstBlankCol), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
            End With
            .SetRange ws.Range("a1", LastCell(ws))
            .Header = xlYes    'is this correct for your layout?
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        'delete the helper columns
        .Range(FirstBlankCol & ":" & FirstBlankCol + 1).Delete
        .AutoFilterMode = False
    End With

    Set FilteredRngToDelete = Nothing
    Set LastCll = Nothing
    Set ws = Nothing

End Sub

Function LastCell(ws As Excel.Worksheet) As Excel.Range
' sourced from http://www.beyondtechnology.com/geeks012.shtml
'Obj: to identify the lastcell on a worksheet (& not necessarily the active sheet)
Dim LastRow As Long
Dim LastCol As Long
    ' Error-handling is here in case there is not any
    ' data in the worksheet
    On Error Resume Next
    With ws
        ' Find the last real populated row
        LastRow = .Cells.Find(What:="*", _
                              SearchDirection:=xlPrevious, _
                              SearchOrder:=xlByRows).Row
        ' Find the last real populated column
        LastCol = .Cells.Find(What:="*", _
                              SearchDirection:=xlPrevious, _
                              SearchOrder:=xlByColumns).Column
        ' Finally, initialize a Range object variable for
        ' the last populated row.
        Set LastCell = .Cells(LastRow, LastCol)
        If LastCell Is Nothing Then Set LastCell = .Cells(1, 1)
    End With
    On Error GoTo 0
End Function

Open in new window


hth
Rob
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 14

Accepted Solution

by:
Faustulus earned 300 total points
ID: 38845906
Please paste the following code to a standard code module in your workbook (by default, it's name would be Module1). Then run the sub DeletePrevious. I think it will do what you want.
Option Explicit

    Enum Nws                    ' Worksheet navigation
        NwsFirstDataRow = 2
        NwsID = 5               ' columns: 5 = E
    End Enum

Sub DeletePrevious()

    Dim Ws As Worksheet
    Dim ID As String
    Dim R As Long
    
    Set Ws = ActiveSheet
    R = NwsFirstDataRow
    
    Do
        ID = Ws.Cells(R, NwsID).Value
        If FindRow(Left(ID, Len(ID) - 1), Ws.Columns(NwsID), R) Then
            Ws.Rows(R).EntireRow.Delete
        Else
            R = R + 1
        End If
    Loop While R <= LastRow(NwsID, Ws)
End Sub

Function FindRow(ByVal SearchFor As Variant, _
                 SearchIn As Range, _
                 Optional ByVal SearchStart As Long = 1, _
                 Optional ByVal SearchDir As Long = xlNext, _
                 Optional ByVal SearchCase As Boolean = True) _
                 As Long
    ' return the number of the row in SearchIn
    ' where SearchFor was found (or 0)
    
    Dim Fnd As Range
    
    If SearchStart = 0 Then SearchStart = SearchIn.Cells.Count
    With SearchIn
        Set Fnd = .Find(What:=SearchFor, _
                        After:=.Cells(SearchStart), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=SearchDir, _
                        MatchCase:=SearchCase)
    End With
    If Not Fnd Is Nothing Then
        If Fnd.Row > SearchStart Then FindRow = Fnd.Row
    End If
End Function

Private Function LastRow(Optional ByVal Col As Variant, _
                         Optional Ws As Worksheet) As Long
    ' 0059 V 3.2 Apr 2, 2012

    ' Return the number of the last non-blank row in column Col.
    ' Specify the column as string or number
    ' If no column is specified,
      ' return the last row from column A.
    ' If no worksheet is specified
      ' return the result from the currently active sheet.
    
    Dim R As Long
    
    If Ws Is Nothing Then Set Ws = ActiveSheet
    If VarType(Col) = vbError Then Col = 1
    With Ws
        R = .Cells(.Rows.Count, Col).End(xlUp).Row
        With .Cells(R, Col)
            ' in a blank column the last used row is 0 (= none)
            If R = 1 And .Value = vbNullString Then R = 0
            ' include all rows of a merged range
            LastRow = R + .MergeArea.Rows.Count - 1
        End With
    End With
End Function

Open in new window

Note that you can change the values of the two enum variables at the top of the code:
NwsFirstDataRow = 2
NwsID = 5
If your first row containing data to be evaluated isn't row 2, replace the number with the real number of the first row containing data, and if the column containing the ID numbers isn't colmn E (=column 5) then change that variable to reflect the actual column to be searched.
0
 

Author Comment

by:NYANBCNY32
ID: 38847404
The macro did work, but there was a change to the report, I don't know if I can tack it in here or do another post that found out on Friday.  The report now pulls inside each Client Record and inside whether it was approved, not approved or pending client approval. I'm attaching just the basic of the form.

Column E still holds the Client Record but it is duplicated of itself and then each time it was touched.  Can it keep the highest, but when the macro is ran not run against the highest but just remove the previous as we have to count each 500 approval?

Not sure if that made sense really, kinda thrown for a twist on Friday.

Client Record      Service Approval      Date Approved
13013178910104      500      2/1/2013
13013178910104      500      2/1/2013
13013178910104      500      2/1/2013
13013178910103      500      1/22/2013
13013178910103      400      1/22/2013
13013178910103      200      1/22/2013
SheetExample.xlsx
0
 
LVL 14

Expert Comment

by:Faustulus
ID: 38847837
Several experts have submitted their code. I think you should decide which code you want, give the fellow his points and then open another question to amend the code which you have chosen.
0
 

Author Closing Comment

by:NYANBCNY32
ID: 38848831
Thank you everyone, I do appreciate the help in finding a solution for this problem/question.
0
 
LVL 14

Expert Comment

by:Faustulus
ID: 38849128
Thank you for choosing my solution.
0
 
LVL 10

Expert Comment

by:broro183
ID: 38850208
Thank you for the points. Good luck solving the next part of your puzzle.

Rob
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
In this seventh video of the Xpdf series, we discuss and demonstrate the PDFfonts utility, which lists all the fonts used in a PDF file. It does this via a command line interface, making it suitable for use in programs, scripts, batch files — any pl…

735 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question