Solved

Delete entries based on date added

Posted on 2011-09-05
6
195 Views
Last Modified: 2012-05-12
I need VBA to combine Worksheet 1 and Worksheet  2 to end up with Worksheet 3.  Then delete all duplicates in Worksheet 3 based on dated added. (keep oldest).

Worksheet 1.

Group      Number      Option      Description      Pct      Date Added
BLUE      432      &ABC      CRAYONS      0.25      8/4/2011
YELLOW      433      &BCA      CRAYONS      0.15      8/4/2011
                              
                              
Worksheet 2

Group      Number      Option      Description      Pct      Date Added
BLUE      432      &ABC      CRAYONS      0.25      9/5/2011
YELLOW      433      &BCA      CRAYONS      0.15      9/5/2011
RED      444      &DAA      CRAYONS      0.12      9/5/2011

Combined Worksheet 3

Group      Number      Option      Description      Pct      Date Added
BLUE      432      &ABC      CRAYONS      0.25      8/4/2011
BLUE      432      &ABC      CRAYONS      0.25      9/5/2011
YELLOW      433      &BCA      CRAYONS      0.15      8/4/2011
YELLOW      433      &BCA      CRAYONS      0.15      9/5/2011
RED      444      &DAA      CRAYONS      0.12      9/5/2011
0
Comment
Question by:mato01
  • 3
  • 2
6 Comments
 
LVL 31

Expert Comment

by:Rob Henson
ID: 36484925
The copy from worksheet 1 and 2 to 3 will be fairly simple.

Once you have the combined sheet, you could then sort on Group and date descending.

Then add a column that does a count of group, make first row of data absolute and relative as it is copied down.

Then the first instance of a group which will be the oldest because of the sort and will be numbered 1 so you can then filter on this column for not equal to 1 and delete those visible.

Does that sound like what you need?

Thanks
Rob H
0
 

Author Comment

by:mato01
ID: 36485035
I may be in the wrong zone. I wanted to do this with code. (not manually)
0
 
LVL 31

Expert Comment

by:Rob Henson
ID: 36485074
No, I was checking that I had the process correct before creating the code.

0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 31

Expert Comment

by:Rob Henson
ID: 36485080
Code so far:

Sub Filter()
'
' Filter Macro
' Macro recorded 05/09/2011 by Rob Henson
'

'
    'Sheets.Add
    'ActiveWorksheet.Name = "copy"
    
    Sheets("Sheet1").Select
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Copy
    Sheets("copy").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    Sheets("Sheet2").Select
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Copy
    Sheets("copy").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.EntireRow.Delete
    
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range( _
        "F2"), Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase _
        :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
        DataOption2:=xlSortNormal
    Range("G1").Select
    Range("G1") = "Occurence"
    
    ActiveCell.Offset(0, -1).Range("A1:B1").Select
    Range(Selection, Selection.End(xlDown)).Select
    For Each Cell In Selection
    Count = Count + 1
    Next Cell
    Count = Count / 2
    
    For R = 2 To Count
    
    Cells(R, 7).FormulaR1C1 = "=COUNTIF(R2C[-6]:RC[-6],RC[-6])"
    Next R
        
    Range("A1").Select
    
    Selection.AutoFilter
    Selection.AutoFilter Field:=7, Criteria1:="<>1", Operator:=xlAnd
    Selection.CurrentRegion.Select
    Selection.EntireRow.Delete
    Range("A1").Select
    Selection.EntireRow.Insert
    
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.Copy
    Sheets("copy").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
End Sub

Open in new window


Got a problem with adding a sheet and then referring to it. Will keep investigating.

Thanks
Rob H
0
 

Author Comment

by:mato01
ID: 36485173
Thanks
0
 
LVL 92

Accepted Solution

by:
Patrick Matthews earned 125 total points
ID: 36485367
The attached file shows another way to do it, using class modules.  Class modules can seem daunting at first, but in many ways it can simplify tasks such as these, and I can usually create parent/child classes very quickly and easily because I have actually automated a lot of the tedium involved (see http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/A_3802-Parent-Class-Builder-Add-In-for-Microsoft-Excel.html).

In the attached module, run the macro DoIt; the code in the parent class will go through every worksheet in the active workbook looking for and sifting through the data, and output the results, one row per group, to a new worksheet.

Class module clsGroups:

' Created by Patrick Matthews, Verint Systems
' Created 2011-09-05

' Parent collection class of clsGroup

Option Explicit
Option Compare Text

' Container for all clsGroup objects in the parent collection class
Private coll As Collection

Private Sub Class_Initialize()
    
    Set coll = New Collection
    
End Sub

Private Sub Class_Terminate()
    
    Set coll = Nothing
    
End Sub

Public Function Add(Group As String) As clsGroup
    
    ' Adds a new item to the collection.  Causes an error if an item with the same key already exists
    ' or if you pass a zero length string for the Group argument
    
    If Group = "" Then
        Err.Raise vbObjectError + 1002, , "Group property of clsGroup object cannot be zero length string"
    End If
    
    Set Add = New clsGroup
    Add.Group = Group

    ' Raise an error and set return value to Nothing if we fail to add item to collection (most likely
    ' because an item already exists with the same key
    
    On Error GoTo ErrHandler
    coll.Add Add, Group

    Exit Function
    
ErrHandler:

    Set Add = Nothing
    Err.Raise vbObjectError + 1003, , "Could not add item '" & Group & "' to clsGroups collection"
    
End Function

Public Sub Clear()
    
    ' Recreates (and thus clears) collection
    
    Set coll = New Collection
    
End Sub

Property Get Count() As Long
    
    ' Returns number of items in the collection
    
    ' Read-only
    
    Count = coll.Count
    
End Property

Function Exists(Group As String) As Boolean

    ' Returns True if a clsGroup member specified by the Group exists in clsGroups parent collection

    Dim TempItem As clsGroup

    On Error GoTo CleanUp

    ' Default return is False
    Exists = False

    ' If item exists, then the Set operation completes without error
    Set TempItem = coll(Group)
    Exists = True

CleanUp:

    Set TempItem = Nothing

End Function

Sub Export()
    
    Dim grp As clsGroup
    Dim Counter As Long
    
    With ActiveWorkbook
        .Worksheets.Add After:=.Worksheets(.Sheets.Count)
    End With
    
    [a1:f1] = Array("Group", "Number", "Option", "Description", "Pct", "Date Added")
    [e:e].NumberFormat = "0.00"
    [f:f].NumberFormat = "yyyy-mm-dd"
    
    For Counter = 1 To Me.Count
        Set grp = Me(Counter)
        Cells(Counter + 1, 1).Resize(1, 6) = _
            Array(grp.Group, grp.GroupNumber, grp.GroupOption, grp.Descr, grp.Pct, grp.DateAdded)
    Next
    
    Columns.AutoFit
    
    On Error Resume Next
    ActiveSheet.Name = "Results"
    On Error GoTo 0
    
    Set grp = Nothing
    
End Sub

Sub Import()
    
    Dim ws As Worksheet
    Dim LastR As Long
    Dim arr As Variant
    Dim Counter As Long
    Dim TestGroup As String
    Dim TestDate As Date
    Dim grp As clsGroup
    
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            If .[a1] = "Group" Then
                LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
                arr = .Range("a1:f" & LastR).Value
                For Counter = 2 To LastR
                    TestGroup = arr(Counter, 1)
                    TestDate = arr(Counter, 6)
                    If Me.Exists(TestGroup) Then
                        Set grp = Me(TestGroup)
                    Else
                        Set grp = Me.Add(TestGroup)
                    End If
                    If TestDate > grp.DateAdded Then
                        grp.GroupNumber = arr(Counter, 2)
                        grp.GroupOption = arr(Counter, 3)
                        grp.Descr = arr(Counter, 4)
                        grp.Pct = arr(Counter, 5)
                        grp.DateAdded = TestDate
                    End If
                Next
            End If
        End With
    Next
    
    Set grp = Nothing
    
End Sub

Property Get Item(Index As Variant) As clsGroup
    
    ' Default property.  Returns an item from the collection.  Index may be either ordinal position (Long) or Group (String)
    
    ' Read-only
    
    On Error GoTo ErrHandler
    Set Item = coll(Index)

    Exit Property

ErrHandler:

    Set Item = Nothing
    Err.Raise vbObjectError + 1004, , "Item does not exist in clsGroups collection"
    
End Property

Function Keys() As Variant

    ' Returns a 1-based array of the various strings used as Group key values for the clsGroup items
    ' in the clsGroups collection"

    Dim Counter As Long
    Dim Results() As String

    ' If there are no items in the clsGroups collection then raise an error
    If Me.Count > 0 Then

        ' Redimension array so there is one member per clsGroup item in clsGroups collection
        ReDim Results(1 To Me.Count) As String

        ' Loop through clsGroups collection and grab Group values for each clsGroup item
        For Counter = 1 To Me.Count
            Results(Counter) = Me(Counter).Group
        Next

        ' Set return value
        Keys = Results

    Else

        ' Raise error for no items
        Err.Raise vbObjectError + 1005, , "Keys method failed: no clsGroup items exist in clsGroups collection"

    End If

End Function

Public Sub Remove(Index As Variant)
    
    ' Removes an item from the collection.  Index may be either ordinal position (Long) or Group (String)
    
    coll.Remove Index
    
End Sub

Function NewEnum() As IUnknown

    ' Enables enumeration of the clsGroups parent collection, i.e.:
    '
    ' For Each Child In Parent...Next
    
    Set NewEnum = coll.[_NewEnum]

End Function

Open in new window





Class module clsGroup:

' Created by Patrick Matthews, Verint Systems
' Created 2011-09-05

Option Explicit
Option Compare Text

Public GroupNumber As Long
Public GroupOption As String
Public Descr As String
Public Pct As Double
Public DateAdded As Date

' Container for "write-once read-many" property
Private Safe_Group As String

Property Get Group() As String
    
    ' Returns item's Group value
    
    Group = Safe_Group
    
End Property

Property Let Group(GroupString As String)
    
    ' Sets Group value for item
    
    ' This makes the Group property "write once, read many".  If the Group is a zero length string,
    ' the Property Let allows you to change it; if not, the procedure raises a user defined
    ' error.  Basically, we cannot allow changes because we want this property to match the
    ' item's true key used when it was added to the parent clsGroups collection
    
    If Safe_Group = "" Then
        Safe_Group = GroupString
    Else
        Err.Raise vbObjectError + 1001, , "Cannot change Group property of clsGroup object"
    End If
    
End Property

Open in new window





Regular module:

Option Explicit

Sub DoIt()
    
    Dim Groups As clsGroups
    
    Set Groups = New clsGroups
    With Groups
        .Import
        .Export
    End With
    
    MsgBox "Done"
    
End Sub

Open in new window

Q-27291889.xls
0

Featured Post

Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

Join & Write a Comment

Drop Down List with Unique/Distinct Values (enhancing the Combo-Box with a few steps and a little code) David miller (dlmille) Intro Have you ever created a data validation list from a database field or spreadsheet column (e.g., Zip Codes or Co…
Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …

759 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

24 Experts available now in Live!

Get 1:1 Help Now