Help with VB code to extract row content based on criteria

[D_Spark]

I have a workbook with 2x Worksheets “Data” and “Check”
On the worksheet Data I have a series of Values

Column A = Names
Column B = Cost
Column C = Dpt

I want to create a piece of VB code to extract from the list on the “Data” worksheet, only those lines where, there are 3x occurrences for a Name where Cost = zero

Eg

Data Worksheet Values

A1=JohnS
A2=SimonX
A3=JohnS
A4= JoeF
A5=JoeF
A6=JohnS
A7=JoeF
A8=SamK
A9=SamK
A10=SamK

B1=0
B2=15
B3=0
B4= 0
B5=0
B6=0
B7=8
B8=0
B9=0
B10=0


C1=A1
C2=B9
C3=A1
C4= F4
C5=F4
C6=A1
C7=F4
C8=X7
C9=X7
C10=X7

Result of ******* macro button with needed code would clear existing values in “Check” worksheet and show
A1=JohnS
B1=0
C1=A1
A2=SamK
B2=0
C2=X7

 

[venkat1926]

your data is like this in sheet 1
run the macro test below and see the result in sheet 3.

Excel Workbook
	A	B	C
1	name	cost	dept
2	JohnS	0	A1
3	SimonX	15	B9
4	JohnS	0	A1
5	joef	0	F4
6	JoeF	0	F4
7	JohnS	0	A1
8	JoeF	8	F4
9	SamK	0	X7
10	SamK	0	X7
11	SamK	0	X7
Sheet1

the macro is

Sub test()
Dim name As Range, rdata As Range, unq As Range, cunq As Range, filt As Range
Worksheets("sheet1").Activate
Set rdata = Range("A1").CurrentRegion
Set name = rdata.Resize(rdata.Rows.Count, rdata.Columns.Count - 2)
Set unq = Range("A1").End(xlDown).Offset(5, 0)
name.AdvancedFilter xlFilterCopy, , unq, True
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))
For Each cunq In unq
rdata.AutoFilter field:=1, Criteria1:=cunq.Value
Set filt = rdata.SpecialCells(xlCellTypeVisible)

filt.Copy Worksheets("sheet2").Range("A1")

With Worksheets("sheet2")
If WorksheetFunction.CountA(.Columns("A:A")) >= 4 And WorksheetFunction.CountIf(.Columns("B:B"), 0) >= 3 Then
.Range("A1").CurrentRegion.AdvancedFilter xlFilterInPlace, , , True
.UsedRange.Offset(1, 0).Resize(.UsedRange.Rows.Count - 1, .UsedRange.Columns.Count).SpecialCells(xlCellTypeVisible).Copy
Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial


If .FilterMode = True Then .ShowAllData
End If
.Cells.Clear

End With
ActiveSheet.AutoFilterMode = False
Next cunq
Range(Range("a1").End(xlDown).Offset(1, 0), Cells(Rows.Count, "A")).EntireRow.Delete
End Sub

Sub undo()
Worksheets("sheet2").Cells.Clear
 Worksheets("sheet3").Cells.Clear
End Sub