Logic Question - Merging of Progressive Records

A

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
4,564
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Consider this raw data ...

Excel Workbook
BFJNOCRCSCT
1********
2CONTRACTProgram$Facility B$StartEnddupphase1dupphase2dupphase3
1162267College Pro Baseball Acedemy CampHillside ParkUpper Diamond9:30 AM12:00 PM62267Hillside ParkUpper DiamondTRUE*
1262267College Pro Baseball Acedemy CampHillside ParkUpper Diamond1:00 PM3:30 PM62267Hillside ParkUpper DiamondTRUE*
32131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 16:30 PM7:15 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 1TRUE*
33131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 17:15 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 1TRUEDUP
34131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 26:30 PM7:15 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 2TRUE*
35131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 27:15 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 2TRUEDUP
36131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 36:30 PM7:15 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 3TRUE*
37131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 37:15 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 3TRUEDUP
38131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 46:30 PM7:15 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 4TRUE*
39131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 47:15 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 4TRUEDUP
Data


I consider two (or more) records to be "progressive when they share common contract #s and FacilityB$, and the end time of the successive program is equal to, or within 15 minutes, of the end time of the previous record. In the sample database, these progressive records are determined with the formula =IF($CR33<>$CR32,"",IF(ABS($N33-$O32)<=TIME(0,15,0),"DUP","")) in column CT.

As we refer to the data, progressive records would be row 32/33, 34/35, 36/37 and 38/39. They share a common contract number and facility (a result of a concatenation in column CR). Row 11/12, although sharing common contract and facility, they differ in that the start time of row12 is greater than 15 minutes of the end time of row 11.

The purpose of identifying those records that are progressive, is to combine them into one resulting in one record in which the earliest start time of the progressive records, and the latest end time of the progressive record is used to create one record.

In our example ... the dataset would be reduced to this ...

Excel Workbook
BFJNOCRCS
1*******
2CONTRACTProgram$Facility B$StartEnddupphase1dupphase2
1162267College Pro Baseball Acedemy CampHillside ParkUpper Diamond9:30 AM12:00 PM62267Hillside ParkUpper DiamondTRUE
1262267College Pro Baseball Acedemy CampHillside ParkUpper Diamond1:00 PM3:30 PM62267Hillside ParkUpper DiamondTRUE
32131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 16:30 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 1TRUE
33131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 26:30 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 2TRUE
34131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 36:30 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 3TRUE
35131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 46:30 PM8:00 PM131229RIM Park Outdoor FacilitiesBeach Volleyball Court 4TRUE
Data


This process works very well, eliminating the redundant records and merging appropriately, however, problems arise when the times are substituted.

I use this code (in blue) to exchange the end times ...

Rich (BB code): 
Sub merged_duplicates()
'
' **** ELIMINATE And MERGE DUPLICATE RECORDS ****
'
Application.EnableEvents = False

Dim dupholder As Worksheet
Dim rngToCopy As Range
Dim rgnToDelete As Range
Dim llastrow As Long
Dim lmergereccopy As Long
Dim lmergedelete As Long

llastrow = 0
lmergereccopy = 0
Label1 = "IDENTIFYING PROGRESSIVE RECORDS"
With core_data
    .Activate
    .Unprotect
    If .FilterMode Then .ShowAllData 'if main data is filtered, unfilter it
    '.Range("CT3:CT" & .Range("B" & Rows.Count).End(xlUp).Row).Formula = "=IF($CR3=$CR2,""DUP"","""")"
    .Range("CT3:CT" & .Range("B" & Rows.Count).End(xlUp).Row).Formula = "=IF($CR3<>$CR2,"""",if(ABS($N3-$O2)<=time(0,15,0),""DUP"",""""))" 'dupphase3
    llastrow = .Range("a65536").End(xlUp).Row 'determine the last row number
    'With .Range("CR5:CR" & llastrow) 'identify the the range (A5 to DI of the last row)
    lmergereccopy = WorksheetFunction.CountIf(.Range("CT2:CT" & llastrow), "DUP")
    'End With
    ' if there are no duplicates than no need to merge any. Finish.
    If lmergereccopy = 0 Then
        'MsgBox "There are no records to be merged.", , "NO DUPLICATES"
            TextBox5.Visible = True
            TextBox5.Value = 0
            TextBox5.Locked = True
            If .FilterMode Then .ShowAllData 'return database to display all data
        Exit Sub
    End If
End With
MsgBox (lmergereccopy & " records identified to be merged.")
Label1 = "MERGING RECORDS."
With wshref
    .Unprotect
    '.Activate
    'pivottable determines the number of duplicates per contract number and the mimimum start time from same. Where there are multiple entries, the earliest start time for that contract will be displayed
    .PivotTables("PivotTable5").PivotCache.Refresh
    .Protect
End With
With core_data
    .Activate
    .Range("D2").Select
    Dim rngToDelete2 As Range
    llastrow = 0
    lmergedelete = 0
    llastrow = .Range("a65536").End(xlUp).Row 'calculate the last row visible
    'filter the visible rows to include only those rows in which dupphase3 = "DUP" (ie. duplicated rows)
    With .Range("A2:DI" & llastrow)
            .AdvancedFilter _
                    Action:=xlFilterInPlace, _
                    CriteriaRange:=Worksheets("Reference").Range("A29:A30"), _
                    Unique:=False
            On Error Resume Next
            Set rngToDelete2 = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) 'this range is the group of visible rows representing those found from the filter
            On Error GoTo 0
            'lmergedelete = .rngToDelete.Count 'how many rows in the visible range of data
            lmergedelete = llastrow - WorksheetFunction.Count(core_data.Columns("A"))
            MsgBox lmergedelete & (" Duplicates being merged.")
            TextBox5.Visible = True
            TextBox5.Value = lmergedelete
            TextBox5.Locked = True
            TextBox6 = TextBox6 - lmergedelete
            If Not rngToDelete2 Is Nothing Then rngToDelete2.EntireRow.Delete 'delete the visible rows (ie the duplicated)
            Label1 = "Extraneous records from merging removed."
        End With
    With core_data
        If .FilterMode Then .ShowAllData ' show all data. All duplicates are removed, leaving only one of the duplicated contracts in the database
        .Range("O3:O" & .Range("A" & Rows.Count).End(xlUp).Row).Formula = "=VLOOKUP($CR3,DatabaseRG3,3,FALSE)" 'using the min times from the pivottable, replace existing start times with min.
        .Protect
    End With
End With
End Sub

Here is the contents of pivottable2:

Excel Workbook
ADAEAF
1*Data*
2dupphase1Count of EndMax of End2
360403RIM Park Outdoor FacilitiesAF-1 (Artificial Field)19:00 PM
460403RIM Park Outdoor FacilitiesAF-2 (Artificial Field)211:00 PM
560933Waterloo ParkWP - Ball Diamond #1111:00 PM
660933Waterloo ParkWP - Ball Diamond #2111:00 PM
760791Auburn ParkBall Diamond18:15 PM
860818Cedarbrae Public SchoolBall Diamond #118:30 PM
960818Cedarbrae Public SchoolBall Diamond #218:30 PM
1060962Conservation MeadowsField18:30 PM
1160655Creekside Church FieldsField 118:15 PM
1260655Creekside Church FieldsField 218:15 PM
1361042Hillside ParkLower Diamond18:15 PM
1460800Lexington Road ParkBall Diamond18:15 PM
1560653Lexington Road ParkSouth Field18:15 PM
1660651Northfield ParkField18:15 PM
1760654Northfield Pond ParkField18:15 PM
1860655Old Oak ParkField - 118:15 PM
1960655Old Oak ParkField - 218:15 PM
2060799Regency ParkBall Diamond18:15 PM
2160746RIM Park Outdoor FacilitiesBall Diamond #119:30 PM
2260746RIM Park Outdoor FacilitiesBall Diamond #219:30 PM
2360794RIM Park Outdoor FacilitiesBall Diamond #3110:15 PM
2460746RIM Park Outdoor FacilitiesBall Diamond #418:00 PM
2560746RIM Park Outdoor FacilitiesBall Diamond #518:00 PM
2660746RIM Park Outdoor FacilitiesBall Diamond #618:00 PM
2760652RIM Park Outdoor FacilitiesField #118:15 PM
2860653RIM Park Outdoor FacilitiesField #1018:15 PM
2960652RIM Park Outdoor FacilitiesField #218:15 PM
3060652RIM Park Outdoor FacilitiesField #318:15 PM
3160652RIM Park Outdoor FacilitiesField #418:15 PM
3260651RIM Park Outdoor FacilitiesField #718:15 PM
3360651RIM Park Outdoor FacilitiesField #818:15 PM
3460653RIM Park Outdoor FacilitiesField #918:15 PM
3560769Waterloo ParkCricket Pitch18:30 PM
3660962Waterloo ParkEast Field18:30 PM
3760725Waterloo ParkWest Field18:15 PM
3860796Waterloo ParkWP - Ball Diamond #318:15 PM
3960801Westwind ParkBall Diamond18:15 PM
4060929Waterloo ParkWP - Ball Diamond #112:00 PM
4160929Waterloo ParkWP - Ball Diamond #212:00 PM
4260929Waterloo ParkWP - Ball Diamond #312:00 PM
4360929Waterloo ParkWP - Ball Diamond #412:00 PM
4461482RIM Park Outdoor FacilitiesAF-1 (Artificial Field)111:00 PM
45131229RIM Park Outdoor FacilitiesBeach Volleyball Court 128:00 PM
46131229RIM Park Outdoor FacilitiesBeach Volleyball Court 228:00 PM
47131229RIM Park Outdoor FacilitiesBeach Volleyball Court 328:00 PM
48131229RIM Park Outdoor FacilitiesBeach Volleyball Court 428:00 PM
4961663Waterloo ParkWP - Ball Diamond #418:00 PM
5060533Waterloo ParkWest Field111:30 AM
5160746Hillside ParkLower Diamond110:00 PM
5262267Hillside ParkUpper Diamond23:30 PM
5361047Hillside ParkUpper Diamond18:30 PM
5460746Hillside ParkUpper Diamond110:00 PM
5561570RIM Park Outdoor FacilitiesField #7111:00 AM
Reference


The resulting data:

Excel Workbook
BFJNOPCRCSCT
1*********
2CONTRACTProgram$Facility B$StartEndChargesdupphase1dupphase2dupphase3
1162267College Pro Baseball Acedemy CampHillside ParkUpper Diamond9:30 AM3:30 PM3.7862267Hillside ParkUpper DiamondTRUE*
1262267College Pro Baseball Acedemy CampHillside ParkUpper Diamond1:00 PM3:30 PM3.7862267Hillside ParkUpper DiamondTRUE*
31131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 16:30 PM8:00 PM*131229RIM Park Outdoor FacilitiesBeach Volleyball Court 1FALSE*
32131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 26:30 PM8:00 PM*131229RIM Park Outdoor FacilitiesBeach Volleyball Court 2FALSE#REF!
33131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 36:30 PM8:00 PM*131229RIM Park Outdoor FacilitiesBeach Volleyball Court 3FALSE#REF!
34131229CARL Beach VolleyballRIM Park Outdoor FacilitiesBeach Volleyball Court 46:30 PM8:00 PM*131229RIM Park Outdoor FacilitiesBeach Volleyball Court 4FALSE#REF!
Data


In most part it works, but the time of non-progressive records is incorrectly changed. In this case, the end time of row11 should be 12:00PM ... it should have not changed.

The question: Does anyone have any solution as how to avoid inadvertently changing the end times on for progressive records. I think the Pivottable is a bit too generic.

Jenn
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
You must log in or register to reply here.

Similar threads

A
  • Question
Incorrect Value being Applied To Cell From Code
Replies
4
Views
402
Ark68
A

Forum statistics

Threads
1,221,556
Messages
6,160,476
Members
451,649
Latest member
fahad_ibnfurjan

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top