?
Solved

Delete entries based on date added

Posted on 2011-09-05
6
Medium Priority
?
208 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
[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
  • 2
6 Comments
 
LVL 33

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 33

Expert Comment

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

0
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
LVL 33

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 93

Accepted Solution

by:
Patrick Matthews earned 500 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

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

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

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

752 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