Help with VB code to extract row content based on criteria

D_Spark

Board Regular
Joined
Feb 4, 2007
Messages
232
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
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

venkat1926

Well-known Member
Joined
Aug 21, 2005
Messages
4,824
your data is like this in sheet 1
run the macro test below and see the result in sheet 3.

Excel Workbook
ABC
1namecostdept
2JohnS0A1
3SimonX15B9
4JohnS0A1
5joef0F4
6JoeF0F4
7JohnS0A1
8JoeF8F4
9SamK0X7
10SamK0X7
11SamK0X7
Sheet1


the macro is

Code:
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


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

Watch MrExcel Video

Forum statistics

Threads
1,122,511
Messages
5,596,581
Members
414,079
Latest member
Frills

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
Top