Retain set of 4 Days Data, based on Row data in 3 columns, and delete rest

[analyst]

I have a spreadsheet where data (Range A:O) could vary from 1500 rows to 5000 rows daily. Row 1 (A1:O1) has Header, and should remain intact.

Column B, Column C, and Column D could have duplicate data IN ROWS, but 'Column O' having DATE data distinguishes each row.

The current structure is such that, I've lined up data datewise, and in all situations, for identical data series based on column B, ColumnC, and Column D, there should be data for maximum 4 days, on which I can carry on my further analysis, but wherever data set (based on identical data in Column B, ColumnC, and ColumnD is less than 4 days, I want to delete such rows).

So, I need a macro which would do as under;

Wherever, data is less than 4days, I want to delete such rows, and move data(ROW) up.

For instance, in given sample file, (see pic)

http://i.imgur.com/nhW9xYQ.jpg

Row 2 & 3 having similar data (In column B, Column C, Column D) is only for two days (5 Dec 2013, and 6 Dec 2013), so i want to delete these two rows

Row 4 & 5 having similar data (In column B, Column C, Column D) is only for two days (5 Dec 2013, and 9 Dec 2013), so i want to delete these two rows

Row 6, 7, & 8 having similar data (In column B, Column C, Column D) is only for three days (5 Dec 2013, 6 Dec 2013 and 9 Dec 2013), so i want to delete these three rows

BUT

Row 11,12,13,14 has 4 days of sequential data which only, I want to keep.

In my main workbook, there could be several such sets of 4 days data as in case of Row 11 to Row14
Since Row 2 to 10 does not meet my criteria such rows should be deleted and data in subsequent rows should be lifted up. Sample data file is attached.

[snb]

Sub M_snb()
[D2:D20] = [if(d2:D20="","",if(countif($D$2:$D$20,D2:D20)=4,D2:D20,""))]
Columns(4).SpecialCells(4).EntireRow.Delete
End Sub

[Admin]

Try


Option Explicit

Sub kTest()

Dim d, i As Long, c As String, a As String, r As Range

Set r = Range("a1").CurrentRegion.Resize(, 15)
d = r.Value2
Application.ScreenUpdating = 0
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = UBound(d, 1) To 2 Step -1
c = d(i, 2) & "|" & d(i, 3) & "|" & d(i, 4)
.Item(c) = .Item(c) + 1
Next
For i = UBound(d, 1) To 2 Step -1
c = d(i, 2) & "|" & d(i, 3) & "|" & d(i, 4)
If .Item(c) < 4 Then
a = a & ",a" & i
If Len(a) > 245 Then
r.Range(Mid(a, 2)).EntireRow.Delete
a = vbNullString
End If
End If
Next
If Len(a) > 1 Then
r.Range(Mid(a, 2)).EntireRow.Delete
a = vbNullString
End If
End With
Application.ScreenUpdating = 1

End Sub

[analyst]

@Admin, Perfectly as desired, Thanks.

@ Snb, thanks.

[snb]

What's wrong with the suggestion I did ?
Applied to your workbook the result is exactly how you formulated it should be.

[analyst]

@ SNB,

Bro., nothing is wrong with your suggestion. Why do u feel like this? Thanks, Again.

[analyst]

Dear Admin,

Which line should be changed to what, (solution given in # 3 above), if i expand one more column upto P (Column P has only numeric value), and data test is now for 6 days, instead of 4 days.

I changed line 15 from


If .Item(c) < 4 Then

to


If .Item(c) < 6 Then

This works, but what i observe is that Column P data (before macro is executed) changes does not come inline with what it has originally.

[bakerman]

Without any further testing, change Resize(,15) to Resize(,16)

[analyst]

@bakerman,

Thanks, I did that also as A:O is 15 columns, and Column P would be 16th Column.

Albeit with that also, macro gets executed, data in Column P is not correctly brought in line with other row data. :(

[Admin]

Since Col P data has nothing to do with this macro, how it is not brought line with other data ?
The unique data comprises col 2,3 and 4, right ?

[analyst]

COrrected, I was calling separate procedure to sort the data, where I made mistkake.

Correction in code, is as i mentioned in # 7, and as suggested by Brother bakerman #8. Thanks.

Versatile code, very useful. Much obliged.