How to return specific rows that meets the set criteria via excel VBA

Question

I have this data and I am tracking the consecutive and multiple occurrence of defect code.
Consecutive defect code are those that appear under the same area and line consecutively.
Multiple are those defect code that appear 3 times or more (even if not conscutive)
under the same area and line.

Area    Line    Lot #           Date              Code  Description
Assy    Line1   LOT000000001    10/3/2013 13:31   5c    Vibration fail
Assy    Line12  LOT000000002    10/3/2013 13:25   5g    Key Malfunction
Labl    Line2   LOT000000003    10/3/2013 13:08   5a    No charge
Dice    Line1   LOT000000004    10/3/2013 13:03   5b    System Fail
Dice    Line2   LOT000000005    10/3/2013 13:09   3j    Sofwware fail
Dice    Line3   LOT000000006    10/3/2013 13:29   5d    No display
Circ    Line1   LOT000000007    10/3/2013 13:25   3n    Short
Circ    Line1   LOT000000008    10/3/2013 13:38   3n    Short
Circ    Line10  LOT000000009    10/3/2013 13:26   3n    Short
Circ    Line12  LOT000000010    10/3/2013 13:30   3n    Short
Circ    Line2   LOT000000011    10/3/2013 13:02   3n    Short
Circ    Line3   LOT000000012    10/3/2013 13:15   3n    Short
Circ    Line7   LOT000000013    10/3/2013 13:24   3n    Short
Circ    LineA   LOT000000014    10/3/2013 13:10   3o    Open
Circ    LineA   LOT000000015    10/3/2013 13:14   3n    Short
Circ    LineA   LOT000000016    10/3/2013 13:46   3c    High Res
Circ    LineA   LOT000000017    10/3/2013 13:47   3n    Short
Circ    LineA   LOT000000018    10/3/2013 13:50   3o    Open
Circ    LineA   LOT000000019    10/3/2013 13:51   3n    Short
Circ    LineA   LOT000000020    10/3/2013 13:55   3b    Low Res
OSTS    Line1   LOT000000021    10/3/2013 13:48   3b    Low Res
OSTS    Line1   LOT000000022    10/3/2013 13:50   3f    No Trace
OSTS    Line11  LOT000000023    10/3/2013 13:06   3a    No Signal
OSTS    Line2   LOT000000024    10/3/2013 13:24   3a    No Signal

In this case, my expected result would be:

Circ    Line1   LOT000000007    10/3/2013 13:25   3n    Short
Circ    Line1   LOT000000008    10/3/2013 13:38   3n    Short

for the consecutive occurrence.

and this for the multiple occurrence.

Circ    LineA   LOT000000015    10/3/2013 13:14   3n    Short
Circ    LineA   LOT000000017    10/3/2013 13:47   3n    Short
Circ    LineA   LOT000000019    10/3/2013 13:51   3n    Short

So the original data is on Sheet1 and I want the result transferred in Sheet2 with the same header.
What I did is to pass the original data into an array and then iterate through it.
I am not getting what I want though. The code is long so I did not bother to post.

And I think is it easier to make a new code than to debug mine.
Any help will be much appreciated. Thanks in advance.
If you still have questions, just fire it away.

Answer 1

formula in I2 = =A2&B2&G2
formula in J2 = =COUNTIF($I$2:$I$25,I2)
formula in K2 = =I2=I3
formula in L2 = =IF(OR(K2,J2>=3,K1),"Copy","Do not copy")

Filter the data in column L and copy to desired sheet.

Answer 2

I am also in favor of using formulas for this and the screenshot that I gave in the comments in your post was derived using formulas. However since you wanted a VBA code, Here it is.

Let's say, your sheet looks like this

Logic:

1. Find Last Row of Sheet1
2. Insert the formula =A2&B2&D2&F2 in Col H
3. Insert the formula =IF(H2=H3,"YES",IF(H2=H1,"YES","")) in Col I

4. Insert the formula =IF(AND(I2="",COUNTIF(H:H,H2)>2),"YES" & H2,"") in Col J

   • The objective to achieve this

   

5. Next Create 2 Sheets for output. Let's output the consecutive records to Consecutive Sheet and multiple records to Multiple sheets

6. Filter the Col I for Yes and move them to Consecutive sheet
7. Filter the Col J for Non Blanks and move them to Multiple sheet
8. Sort the data in Multiple sheet based on Col J
9. Delete Columns H:J from all sheets

Code:

Option Explicit

Sub Sample()
    Dim ws As Worksheet, wsConsc As Worksheet, wsMulti As Worksheet
    Dim lRow As Long

    '~~> Change this to the releavnt sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    '~~> To create Consecutive and Multi sheets, delete existing ones if appl
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("Consecutive").Delete
    ThisWorkbook.Sheets("Multi").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    '~~> Create new sheets for output
    Set wsConsc = ThisWorkbook.Sheets.Add: wsConsc.Name = "Consecutive"
    Set wsMulti = ThisWorkbook.Sheets.Add: wsMulti.Name = "Multi"

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        .Columns("H:J").ClearContents

        .Range("H2:H" & lRow).Formula = "=A2&B2&D2&F2"
        .Range("I2:I" & lRow).Formula = "=IF(H2=H3,""YES"",IF(H2=H1,""YES"",""""))"
        .Range("J2:J" & lRow).Formula = "=IF(AND(I2="""",COUNTIF(H:H,H2)>2),""YES"" & H2,"""")"

        .Range("H2:J" & lRow).Value = .Range("H2:J" & lRow).Value

        .AutoFilterMode = False

        With .Range("I1:I" & lRow)
            .AutoFilter Field:=1, Criteria1:="=YES"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            wsConsc.Rows(1)
        End With

        .AutoFilterMode = False

        With .Range("J1:J" & lRow)
            .AutoFilter Field:=1, Criteria1:="<>"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            wsMulti.Rows(1)

            wsMulti.Columns("A:J").Sort Key1:=wsMulti.Range("J2"), Order1:=xlAscending, Header:=xlYes, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        End With

        .AutoFilterMode = False

        .Columns("H:J").ClearContents
        wsConsc.Columns("H:J").ClearContents
        wsMulti.Columns("H:J").ClearContents
    End With
End Sub

Output: