Solved

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

Posted on 2013-01-31
9
469 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
  • 3
  • 3
  • 2
  • +1
9 Comments
 
LVL 6

Assisted Solution

by:nickinthooz
nickinthooz earned 25 total points
Comment Utility
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
Comment Utility
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
Comment Utility
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
 
LVL 14

Accepted Solution

by:
Faustulus earned 300 total points
Comment Utility
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
Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

 

Author Comment

by:NYANBCNY32
Comment Utility
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
Comment Utility
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
Comment Utility
Thank you everyone, I do appreciate the help in finding a solution for this problem/question.
0
 
LVL 14

Expert Comment

by:Faustulus
Comment Utility
Thank you for choosing my solution.
0
 
LVL 10

Expert Comment

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

Rob
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
Although it can be difficult to imagine, someday your child will have a career of his or her own. He or she will likely start a family, buy a home and start having their own children. So, while being a kid is still extremely important, it’s also …
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

744 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now