Excel VBA ( Filter Headers down in Sheet1 when Meeting Criteria and paste to Sheet2)

raflyshaq · Feb 8, 2017

Dear Sir,

So far, my codes are only working for columns Date, Name, Value, but for Color always failed. I need to filter down Src.Range("C3:G3") when meeting criteria sname and Src.Range("C4:G").Value > 0 then Paste/copied to Dst.Range("C2:C") automatically as below figures.

My Codes are as follows :

 [FONT=&quot]Private Sub CommandButton1_Click()[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]Application.ScreenUpdating = False[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]Dim c As Range[/FONT]
[FONT=&quot]Dim sname As String[/FONT]

[FONT=&quot]Dim rng As Range[/FONT]
[FONT=&quot]Dim Src As Worksheet[/FONT]
[FONT=&quot]Dim Dst As Worksheet[/FONT]

[FONT=&quot] [/FONT]
[FONT=&quot]Set Src = Sheet1[/FONT]
[FONT=&quot]Set Dst = Sheet2[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]With Sheet2[/FONT]
[FONT=&quot]Dst.Range("A2:D10").ClearContents[/FONT]
[FONT=&quot]End With[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]sname = Sheet1.Range("K5").Value[/FONT]
[FONT=&quot]Set rng = Application.Intersect(Src.Range("B:B"), Src.UsedRange)[/FONT]

[FONT=&quot] [/FONT]
[FONT=&quot]For Each c In rng.Cells[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]If c.Value = sname Then[/FONT]
[FONT=&quot]On Error Resume Next[/FONT]
[FONT=&quot]c.Offset(0, -1).Resize(1, 1).Copy Dst.Cells(5, 1).End(xlUp).Offset(1, 0)[/FONT]
[FONT=&quot]c.Offset(0, 0).Resize(1, 1).Copy Dst.Cells(5, 2).End(xlUp).Offset(1, 0)[/FONT]
[FONT=&quot]c.Offset(0, 6).Resize(1, 1).End(xlToLeft).Copy Dst.Cells(5, 4).End(xlUp).Offset(1, 0)[/FONT]

[FONT=&quot]End If[/FONT]

[FONT=&quot]Next[/FONT]

[FONT=&quot] [/FONT]

[FONT=&quot]Application.ScreenUpdating = True[/FONT]

[FONT=&quot] [/FONT]

[FONT=&quot]End Sub[/FONT]

[FONT=&quot] [/FONT]

	A	B	C	D	E	F	G	H	I	J	K
1	Sheet1
2
3	Date	Name	White	Blue	Green	Red	Black	Value
4	01-Jan-2017	John	1					1
5	01-Jan-2017	John		2				2	Command	Button1	John
6	01-Jan-2017	John			3			3
7	01-Jan-2017	John				4		4
8	02-Jan-2017	Marry					5	5
9	02-Jan-2017	Marry				6		6
10	02-Jan-2017	Marry			7			7
11	02-Jan-2017	Marry		8				8

Sheet2

	A	B	C	D
1	Date	Name	Color	Value
2	01-Jan-2017	John	White	1
3	01-Jan-2017	John	Blue	2
4	01-Jan-2017	John	Green	3
5	01-Jan-2017	John	Red	4

Or

Sheet2

	A	B	C	D
1	Date	Name	Color	Value
2	02-Jan-2017	Marry	Black	5
3	02-Jan-2017	Marry	Red	6
4	02-Jan-2017	Marry	Green	5
5	02-Jan-2017	Marry	Blue	8

I will Appreciate if you could solve the problem.

Kind regards,
Raflyshaq

raflyshaq · Feb 9, 2017

Revise Value :

4 02-Jan-2017 Marry Green 7 (Instead of 5)

Is there anyone who could solve the problem ?

Excel VBA ( Filter Headers down in Sheet1 when Meeting Criteria and paste to Sheet2)

raflyshaq

New Member

Excel Facts

raflyshaq

New Member

Similar threads

Forum statistics

Share this page

Excel VBA ( Filter Headers down in Sheet1 when Meeting Criteria and paste to Sheet2)

raflyshaq

New Member

Excel Facts

raflyshaq

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock