VBA Code Required

[hrayani]

Hello Friends,

I want to copy specific data in specific format from one worksheet to another (both worksheet in the same workbook)

Here is the short sample data

Running Orders New Style.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
2	PO #	REF #	PO DATE	Customer	Supplier	Article	Quality	Dyed or Printed	Fiber Content	Construction	SIZE	QTY	UNIT	PO SHIP DATE	ACTUAL SHIP DATE	REMARKS	SAMPLING	PO # CONCAT	ARTICLE CONCAT	EXTRA COLUMN	VALUE	STATUS
3	377421	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Normal	143,760	Set(s)	2-May-22			OCT - 2021	377421	Bed Set		$699,576	In Process
4	377422	633	29-Dec-21	TEX 1	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Disperse Dyed + Dispers Print	100% Polyester	75D X 200D 107X66	Multiple	233,544	Pair(s)	2-May-22			OCT - 2021	377421 - 377422	Bed Set - Pillow Pair		$452,181	In Process
5	377423	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Over	94,240	Set(s)	2-May-22			OCT - 2021	377421 - 377422 - 377423	Bed Set - Pillow Pair		$673,612	In Process
6	377424	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	King	37,110	Set(s)	2-May-22			OCT - 2021	377421 - 377422 - 377423 - 377424	Bed Set - Pillow Pair		$309,762	In Process
7	377425	633	29-Dec-21	TEX 1	Mills	Side Pillow	Microfiber Satin - 100 Gsm	Disperse Dyed + Dispers Print	100% Polyester	75D X 200D 107X66	40x145	176,532	Pc(s)	2-May-22			OCT - 2021	377421 - 377422 - 377423 - 377424 - 377425	Bed Set - Pillow Pair - Side Pillow		$307,166	In Process
8	980154	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Normal	59,976	Set(s)	6-Jun-22			OCT - 2021	980154	Bed Set		$249,122	In Process
9	980155	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	King	25,410	Set(s)	6-Jun-22			OCT - 2021	980154 - 980155	Bed Set		$170,777	In Process
10	980156	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Over	47,976	Set(s)	6-Jun-22			OCT - 2021	980154 - 980155 - 980156	Bed Set		$254,075	In Process
11	980157	634	10-Dec-21	TEX 1	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Multiple	51,240	Pair(s)	6-Jun-22			OCT - 2021	980154 - 980155 - 980156 - 980157	Bed Set - Pillow Pair		$ 41,313	In Process
12	123456	635	10-Dec-21	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	100x200	3,920	Pc(s)	13-Feb-22		Best Price & Easy Sleep - Contract # 21176967		123456	Fitted Sheet		$ 14,896	Shipped
13	123457	635	10-Dec-21	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	150x200	2,400	Pc(s)	13-Feb-22		Best Price & Easy Sleep - Contract # 21176967		123456 - 123457	Fitted Sheet		$ 12,960	Shipped
14	229988	636	14-Dec-21	LOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Pigment Printed Rotary	100% Cotton	30X30 / 76X50	Single	1,416	Set(s)	28-Feb-22				229988	Sheet Set		$ 14,168	In Process
15	229900	636	14-Dec-21	LOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Pigment Printed Rotary	100% Cotton	30X30 / 76X50	Single	3,456	Set(s)	28-Feb-22				229988 - 229900	Sheet Set		$ 41,437	In Process
16	403175	637	21-Dec-21	OFF	Towel	Terry Beach Towel	CTN 320 GSM	Reactive Print	100% Cotton		70x150 cm	60,160	Pc(s)	18-Apr-22		Amount in euro increased to 13%		403175	Terry Beach Towel		$205,982	In Process
17	403176	637	21-Dec-21	OFF	Towel	Poncho	CTN 320 GSM	Reactive Print	100% Cotton		60x120 cm	56,092	Pc(s)	18-Apr-22		Amount in euro increased to 13%		403175 - 403176	Terry Beach Towel - Poncho		$205,998	In Process
18	310088	638	7-Jan-22	OFF	Towel	Terry Towel	CTN 385 GSM	Reactive Dyed	100% Cotton		50x100 cm (2 Pc Set)	142,566	Set(s)	10-Jun-22		Young Living ▬ Amount in euro increased to 14%		310088	Terry Towel		$367,307	Shipped
19	310089	638	7-Jan-22	OFF	Towel	Terry Towel	CTN 385 GSM	Reactive Dyed	100% Cotton		70x140 cm	124,382	Pc(s)	10-Jun-22		Young Living ▬ Amount in euro increased to 14%		310088 - 310089	Terry Towel		$314,786	Shipped
20	567891	639	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	100x200	4,080	Pc(s)	13-May-22		Best Price & Easy Sleep - Contract # 21176967		567891	Fitted Sheet		$ 15,504	Shipped
21	567892	639	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	150x200	2,220	Pc(s)	13-May-22		Best Price & Easy Sleep - Contract # 21176967		567891 - 567892	Fitted Sheet		$ 11,988	Shipped
22	129875	640	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	100x200	3,840	Pc(s)	1-Jun-22		Best Price & Easy Sleep - Contract # 21176967		129875	Fitted Sheet		$ 14,592	Shipped
23	129876	640	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	150x200	2,400	Pc(s)	1-Jun-22		Best Price & Easy Sleep - Contract # 21176967		129875 - 129876	Fitted Sheet		$ 12,960	Shipped
ORDERS

Cell Formulas
Range	Formula
R3:R23	R3	=IF(ISBLANK(B3),"",IF(B3<>B2,A3,IF(ISNUMBER(SEARCH(A3,R2)),R2,R2&" - "&A3)))
S3:S23	S3	=IF(ISBLANK(B3),"",IF(B3<>B2,F3,IF(ISNUMBER(SEARCH(F3,S2)),S2,S2&" - "&F3)))

Sheet 1: Copy from Sheet ORDERS
Sheet2: Copy to Sheet RUNNING ORDER STATUS

I want the data to copied to sheet 2 with following conditions

1) Copy all rows showing "In Process" in Column V from sheet 1 to sheet 2 starting from cell B4
Columns to copy would be A,B,C,D,E,F,G,K,L,M,N & P (Total 12 Columns)

2) Sort Data - 1st by Customer in Alphabetical order then by Ascending order PO ship date

3) Insert a Line when a Ref # changes
a) On the inserted Line: Show 1st instance for columns PO #, REF #, PO Date, Customer, Supplier, Article, Quality, PO Shape Date Columns
b) On the inserted Line: Show "Multiple" if more than one entry is found for Size, Unit & Remarks Columns else show 1st Instance
c) On the inserted Line: Show Total for the Qty Column

4) In Column A add value 1 to all the copied rows & value 2 to all the inserted rows (This is because I will be filtering records further)

5) Content Banding When a Ref # Changes

6) Dark grey color to the Inserted Rows

So, the final look will be like this

Running Orders New Style.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
4		PO #	REF #	PO DATE	Customer	Supplier	Article	Quality	SIZE	QTY	UNIT	PO SHIP DATE	REMARKS
5	1	377421	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Normal	143,760	Set(s)	2-May-22
6	1	377422	633	29-Dec-21	TEX 1	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Multiple	233,544	Pair(s)	2-May-22
7	1	377423	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Over	94,240	Set(s)	2-May-22
8	1	377424	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	King	37,110	Set(s)	2-May-22
9	1	377425	633	29-Dec-21	TEX 1	Mills	Side Pillow	Microfiber Satin - 100 Gsm	40x145	176,532	Pc(s)	2-May-22
10	2	377421	633	29-Dec-22	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Multiple	685,186	Multiple	2-May-22
11	1	980154	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Normal	59,976	Set(s)	6-Jun-22
12	1	980155	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	King	25,410	Set(s)	6-Jun-22
13	1	980156	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Over	47,976	Set(s)	6-Jun-22
14	1	980157	634	10-Dec-21	TEX 1	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Multiple	51,240	Pair(s)	6-Jun-22
15	2	980154	634	10-Dec-22	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Multiple	184,602	Multiple	6-Jun-22
16	1	229988	636	14-Dec-21	LOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Single	1,416	Set(s)	28-Feb-22
17	1	229900	636	14-Dec-21	LOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Single	3,456	Set(s)	28-Feb-22
18	2	229988	636	14-Dec-22	LOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Single	4,872	Set(s)	28-Feb-22
19	1	403175	637	21-Dec-21	OFF	Towel	Terry Beach Towel	CTN 320 GSM	70x150 cm	60,160	Pc(s)	18-Apr-22	Amount in euro increased to 13%
20	1	403176	637	21-Dec-21	OFF	Towel	Poncho	CTN 320 GSM	60x120 cm	56,092	Pc(s)	18-Apr-22	Amount in euro increased to 13%
21	2	403175	637	21-Dec-22	OFF	Towel	Terry Beach Towel	CTN 320 GSM	Multiple	116,252	Pc(s)	18-Apr-22
22	1	377421	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Normal	143,760	Set(s)	2-May-22
23	1	377422	633	29-Dec-21	TEX 1	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Multiple	233,544	Pair(s)	2-May-22
24	1	377423	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Over	94,240	Set(s)	2-May-22
25	1	377424	633	29-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	King	37,110	Set(s)	2-May-22
26	1	377425	633	29-Dec-21	TEX 1	Mills	Side Pillow	Microfiber Satin - 100 Gsm	40x145	176,532	Pc(s)	2-May-22
27	2	377421	633	29-Dec-22	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Multiple	685,186	Multiple	2-May-22
28	1	980154	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Normal	59,976	Set(s)	6-Jun-22
29	1	980155	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	King	25,410	Set(s)	6-Jun-22
30	1	980156	634	10-Dec-21	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Over	47,976	Set(s)	6-Jun-22
31	1	980157	634	10-Dec-21	TEX 1	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Multiple	51,240	Pair(s)	6-Jun-22
32	2	980154	634	10-Dec-22	TEX 1	Mills	Bed Set	Microfiber Satin - 100 Gsm	Multiple	184,602	Multiple	6-Jun-22
RUNNING ORDER STATUS

Any help would be appreciated,

Regards,

Humayun

 

[hrayani]

Ok I will again use the XL2BB addin

This is the order sheet, from which the data is supposed to be copied

Running Orders New Style.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	PO #	REF #	PO DATE	Customer	Supplier	Article	Quality	Dyed or Printed	Fiber Content	Construction	SIZE	QTY	UNIT	PO SHIP DATE	ACTUAL SHIP DATE	REMARKS	SAMPLING	PO # CONCAT	ARTICLE CONCAT	EXTRA COLUMN	VALUE	STATUS
2	377421	633	29-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Normal	143,760	Set(s)	2-May-22			OCT - 2021	377421	Bed Set		$699,576	In Process
3	377422	633	29-Dec-21	TEX 11	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Disperse Dyed + Dispers Print	100% Polyester	75D X 200D 107X66	Multiple	233,544	Pair(s)	2-May-22			OCT - 2021	377421 - 377422	Bed Set - Pillow Pair		$452,181	In Process
4	377423	633	29-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Over	94,240	Set(s)	2-May-22			OCT - 2021	377421 - 377422 - 377423	Bed Set - Pillow Pair		$673,612	In Process
5	377424	633	29-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	King	37,110	Set(s)	2-May-22			OCT - 2021	377421 - 377422 - 377423 - 377424	Bed Set - Pillow Pair		$309,762	In Process
6	377425	633	29-Dec-21	TEX 11	Mills	Side Pillow	Microfiber Satin - 100 Gsm	Disperse Dyed + Dispers Print	100% Polyester	75D X 200D 107X66	40x145	176,532	Pc(s)	2-May-22			OCT - 2021	377421 - 377422 - 377423 - 377424 - 377425	Bed Set - Pillow Pair - Side Pillow		$307,166	In Process
7	980154	634	10-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Normal	59,976	Set(s)	6-Jun-22			OCT - 2021	980154	Bed Set		$249,122	In Process
8	980155	634	10-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	King	25,410	Set(s)	6-Jun-22			OCT - 2021	980154 - 980155	Bed Set		$170,777	In Process
9	980156	634	10-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Over	47,976	Set(s)	6-Jun-22			OCT - 2021	980154 - 980155 - 980156	Bed Set		$254,075	In Process
10	980157	634	10-Dec-21	TEX 11	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Disperse Print	100% Polyester	75D X 200D 107X66	Multiple	51,240	Pair(s)	6-Jun-22			OCT - 2021	980154 - 980155 - 980156 - 980157	Bed Set - Pillow Pair		$ 41,313	In Process
11	123456	635	10-Dec-21	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	100x200	3,920	Pc(s)	13-Feb-22		Best Price & Easy Sleep - Contract # 21176967		123456	Fitted Sheet		$ 14,896	Shipped
12	123457	635	10-Dec-21	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	150x200	2,400	Pc(s)	13-Feb-22		Best Price & Easy Sleep - Contract # 21176967		123456 - 123457	Fitted Sheet		$ 12,960	Shipped
13	229988	636	14-Dec-21	zLOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Pigment Printed Rotary	100% Cotton	30X30 / 76X50	Single	1,416	Set(s)	28-Feb-22				229988	Sheet Set		$ 14,168	In Process
14	229900	636	14-Dec-21	zLOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Pigment Printed Rotary	100% Cotton	30X30 / 76X50	Single	3,456	Set(s)	28-Feb-22				229988 - 229900	Sheet Set		$ 41,437	In Process
15	403175	637	21-Dec-21	OFF	Towel	Terry Beach Towel	CTN 320 GSM	Reactive Print	100% Cotton		70x150 cm	60,160	Pc(s)	18-Apr-22		Amount in euro increased to 13%		403175	Terry Beach Towel		$205,982	In Process
16	403176	637	21-Dec-21	OFF	Towel	Poncho	CTN 320 GSM	Reactive Print	100% Cotton		60x120 cm	56,092	Pc(s)	18-Apr-22		Amount in euro increased to 14%		403175 - 403176	Terry Beach Towel - Poncho		$205,998	In Process
17	310088	638	7-Jan-22	OFF	Towel	Terry Towel	CTN 385 GSM	Reactive Dyed	100% Cotton		50x100 cm (2 Pc Set)	142,566	Set(s)	10-Jun-22		Young Living ▬ Amount in euro increased to 14%		310088	Terry Towel		$367,307	Shipped
18	310089	638	7-Jan-22	OFF	Towel	Terry Towel	CTN 385 GSM	Reactive Dyed	100% Cotton		70x140 cm	124,382	Pc(s)	10-Jun-22		Young Living ▬ Amount in euro increased to 14%		310088 - 310089	Terry Towel		$314,786	Shipped
19	567891	639	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	100x200	4,080	Pc(s)	13-May-22		Best Price & Easy Sleep - Contract # 21176967		567891	Fitted Sheet		$ 15,504	In Process
20	567892	639	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Reactive Dyed	100% Cotton	30'S Cotton	150x200	2,220	Pc(s)	13-May-22		Best Price & Easy Sleep - Contract # 21176967		567891 - 567892	Fitted Sheet		$ 11,988	In Process
ORDERS

Cell Formulas
Range	Formula
R2:R20	R2	=IF(ISBLANK(B2),"",IF(B2<>B1,A2,IF(ISNUMBER(SEARCH(A2,R1)),R1,R1&" - "&A2)))
S2:S20	S2	=IF(ISBLANK(B2),"",IF(B2<>B1,F2,IF(ISNUMBER(SEARCH(F2,S1)),S1,S1&" - "&F2)))

And this is the result sheet

Running Orders New Style.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
3		PO #	REF #	PO DATE	Customer	Supplier	Article	Quality	SIZE	QTY	UNIT	PO SHIP DATE	REMARKS
4	1	403175	637	21-Dec-21	OFF	Towel	Terry Beach Towel	CTN 320 GSM	70x150 cm	60,160	Pc(s)	18-Apr-22	Amount in euro increased to 13%
5	1	403176	637	21-Dec-21	OFF	Towel	Poncho	CTN 320 GSM	60x120 cm	56,092	Pc(s)	18-Apr-22	Amount in euro increased to 14%
6	2	403175	637	21-Dec-21	OFF	Towel	Terry Beach Towel	CTN 320 GSM	Multiple	116,252	Pc(s)	18-Apr-22	Multiple
7	1	567891	639	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	100x200	4,080	Pc(s)	13-May-22	Best Price & Easy Sleep - Contract # 21176967
8	1	567892	639	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	150x200	2,220	Pc(s)	13-May-22	Best Price & Easy Sleep - Contract # 21176967
9	2	567891	639	12-Jan-22	ROS 2	Usman	Fitted Sheet	CTN Jersey - 135 Gsm	Multiple	6,300	Pc(s)	13-May-22	Best Price & Easy Sleep - Contract # 21176967
10	1	377421	633	29-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Normal	143,760	Set(s)	2-May-22
11	1	377422	633	29-Dec-21	TEX 11	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Multiple	233,544	Pair(s)	2-May-22
12	1	377423	633	29-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Over	94,240	Set(s)	2-May-22
13	1	377424	633	29-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	King	37,110	Set(s)	2-May-22
14	1	377425	633	29-Dec-21	TEX 11	Mills	Side Pillow	Microfiber Satin - 100 Gsm	40x145	176,532	Pc(s)	2-May-22
15	2	377421	633	29-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Multiple	685,186	Multiple	2-May-22
16	1	980154	634	10-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Normal	59,976	Set(s)	6-Jun-22
17	1	980155	634	10-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	King	25,410	Set(s)	6-Jun-22
18	1	980156	634	10-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Over	47,976	Set(s)	6-Jun-22
19	1	980157	634	10-Dec-21	TEX 11	Mills	Pillow Pair	Microfiber Satin - 100 Gsm	Multiple	51,240	Pair(s)	6-Jun-22
20	2	980154	634	10-Dec-21	TEX 11	Mills	Bed Set	Microfiber Satin - 100 Gsm	Multiple	184,602	Multiple	6-Jun-22
21	1	229988	636	14-Dec-21	zLOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Single	1,416	Set(s)	28-Feb-22
22	1	229900	636	14-Dec-21	zLOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Single	3,456	Set(s)	28-Feb-22
23	2	229988	636	14-Dec-21	zLOS	Fabrics	Sheet Set	CTN Renforce - 100 Gsm	Single	4,872	Set(s)	28-Feb-22
RUNNING ORDER STATUS

And this is the final code I am using

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, x As Long, i As Long, fRow As Long, lRow As Long, y As Long: y = 19
    Set srcWS = Sheets("ORDERS")
    Set desWS = Sheets("RUNNING ORDER STATUS")
   
    desWS.UsedRange.Rows.Delete
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter 22, "In Process"
        Intersect(.AutoFilter.Range, .Range("A:G,K:N,P:P")).Copy desWS.Range("B3")
        .Range("A1").AutoFilter
    End With
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With desWS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("E3:E" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("L3:L" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("B3:M" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For x = LastRow To 5 Step -1
        With desWS
            If .Cells(x, 3) <> .Cells(x - 1, 3) Then
                .Rows(x).EntireRow.Insert
            End If
        End With
    Next x
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With desWS.Range("B4:B" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 1 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWS
                .Range("B" & lRow + 1 & ":M" & lRow + 1).Value = .Range("B" & fRow & ":M" & fRow).Value
                .Range("J" & lRow + 1).Value = WorksheetFunction.Sum(.Range("J" & fRow & ":J" & lRow))
                .Range("A" & fRow & ":A" & lRow) = 1
                .Range("A" & fRow & ":M" & lRow).Interior.ColorIndex = y
                .Range("A" & lRow + 1) = 2
                .Range("A" & lRow + 1 & ":M" & lRow + 1).Interior.ColorIndex = 15
                Set rng = .Range("I" & fRow & ":I" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("I" & lRow + 1) = rng(1)
                Else
                    .Range("I" & lRow + 1) = "Multiple"
                End If
                Set rng = .Range("K" & fRow & ":K" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("K" & lRow + 1) = rng(1)
                Else
                    .Range("K" & lRow + 1) = "Multiple"
                End If
                Set rng = .Range("M" & fRow & ":M" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("M" & lRow + 1) = rng(1)
                ElseIf rng.Count = WorksheetFunction.CountIf(rng, "") Then
                    .Range("M" & lRow + 1) = ""
                Else
                    .Range("M" & lRow + 1) = "Multiple"
                End If
                If y = 19 Then
                    y = 20
                Else
                    y = 19
                End If
            End With
        Next i
       
    End With
    Application.ScreenUpdating = True
End Sub

I only require 2 changes in the above code

1) At the moment, code is copying the data with the headings starting from row # 3. What I want is, I will type in the headings manually once & format it once manually. I want the code to copy data without the headings starting from row # 4

2) When I re-run the code, don't do anything From row # 1 to 3. Like leave the headings & its formats as it is & erase everything from row # 4 till the last row, before copying fresh data so that it does not get overlap with the existing data

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, x As Long, i As Long, fRow As Long, lRow As Long, y As Long: y = 19
    Set srcWS = Sheets("ORDERS")
    Set desWS = Sheets("RUNNING ORDER STATUS")
    desWS.UsedRange.Rows.Delete
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter 22, "In Process"
        Intersect(.AutoFilter.Range, .Range("A:G,K:N,P:P")).Copy desWS.Range("B1")
        .Range("A1").AutoFilter
    End With
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With desWS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("E2:E" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("L2:L" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("B1:M" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    For x = LastRow To 3 Step -1
        With desWS
            If .Cells(x, 3) <> .Cells(x - 1, 3) Then
                .Rows(x).EntireRow.Insert
            End If
        End With
    Next x
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With desWS.Range("B2:B" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 1 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWS
                .Range("B" & lRow + 1 & ":M" & lRow + 1).Value = .Range("B" & fRow & ":M" & fRow).Value
                .Range("J" & lRow + 1).Value = WorksheetFunction.Sum(.Range("J" & fRow & ":J" & lRow))
                .Range("A" & fRow & ":A" & lRow) = 1
                .Range("A" & fRow & ":M" & lRow).Interior.ColorIndex = y
                .Range("A" & lRow + 1) = 2
                .Range("A" & lRow + 1 & ":M" & lRow + 1).Interior.ColorIndex = 15
                Set rng = .Range("I" & fRow & ":I" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("I" & lRow + 1) = rng(1)
                Else
                    .Range("I" & lRow + 1) = "Multiple"
                End If
                Set rng = .Range("K" & fRow & ":K" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("K" & lRow + 1) = rng(1)
                Else
                    .Range("K" & lRow + 1) = "Multiple"
                End If
                Set rng = .Range("M" & fRow & ":M" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("M" & lRow + 1) = rng(1)
                ElseIf rng.Count = WorksheetFunction.CountIf(rng, "") Then
                    .Range("M" & lRow + 1) = ""
                Else
                    .Range("M" & lRow + 1) = "Multiple"
                End If
                If y = 19 Then
                    y = 20
                Else
                    y = 19
                End If
            End With
        Next i
       
    End With
    Application.ScreenUpdating = True
End Sub

 

[hrayani]

Thanks mumps but it did not work as it is now pasting the data to the destination sheet starting from row # 1 with the headers
Whereas I wanted it to copy the data without the headers & start pasting in the destination sheet starting from Row # 4

Anyways, Just a bit of amendment in your code did the trick

 Intersect(.AutoFilter.Range, .Range("A:G,K:N,P:P")).Offset(1, 0).Copy desWS.Range("B4")

since I did not want to copy the headers from the source sheet, all I did is added the offset function telling the code not to copy row # 1 and set the desWS.Range("B4") so that it starts pasting from row # 4

Thanks again for your time & effort you have put in to help me out. Job is done now

Just out of curiosity & for learning purpose, can you please tell me what the below part of the code is actually doing

For x = LastRow To 5 Step -1
        With desWS
             If .Cells(x, 3) <> .Cells(x - 1, 3) Then
                .Rows(x).EntireRow.Insert
            End If
        End With

 

[mumps]

That code loops through the rows starting from the last row going up to the fifth row and inserts a blank row at each change in column C.

 

[hrayani]

That code loops through the rows starting from the last row going up to the fifth row and inserts a blank row at each change in column C.

After reading this reply, I just tried to play with the code a bit. Like I changed the column number from 3 to 13 & it did exactly as you said so
Many Thanks, Great Learning for me

 

[mumps]

You are very welcome.

 

[hrayani]

You are very welcome.

Hi mumps,

One more question as I am still in learning stage
Can we change this part of the code to count unique entries instead of sum

.Range("K" & lRow + 1).Value = WorksheetFunction.Sum(.Range("K" & fRow & ":K" & lRow))

I tried changing it to count & it does, but I can't get it to work to count unique values

 

[mumps]

Is this what you want?

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, dic As Object
    Dim cel As Range, x As Long, i As Long, fRow As Long, lRow As Long, y As Long: y = 19
    Set srcWS = Sheets("ORDERS")
    Set desWS = Sheets("RUNNING ORDER STATUS")
    desWS.UsedRange.Rows.Delete
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter 22, "In Process"
        Intersect(.AutoFilter.Range, .Range("A:G,K:N,P:P")).Copy desWS.Range("B1")
        .Range("A1").AutoFilter
    End With
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With desWS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("E2:E" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("L2:L" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("B1:M" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    For x = LastRow To 3 Step -1
        With desWS
            If .Cells(x, 3) <> .Cells(x - 1, 3) Then
                .Rows(x).EntireRow.Insert
            End If
        End With
    Next x
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With desWS.Range("B2:B" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 1 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            With desWS
                .Range("B" & lRow + 1 & ":M" & lRow + 1).Value = .Range("B" & fRow & ":M" & fRow).Value
                .Range("J" & lRow + 1).Value = WorksheetFunction.Sum(.Range("J" & fRow & ":J" & lRow))
                .Range("A" & fRow & ":A" & lRow) = 1
                .Range("A" & fRow & ":M" & lRow).Interior.ColorIndex = y
                .Range("A" & lRow + 1) = 2
                .Range("A" & lRow + 1 & ":M" & lRow + 1).Interior.ColorIndex = 15
                Set rng = .Range("I" & fRow & ":I" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("I" & lRow + 1) = rng(1)
                Else
                    .Range("I" & lRow + 1) = "Multiple"
                End If
                Set rng = .Range("K" & fRow & ":K" & lRow)
                Set dic = CreateObject("Scripting.Dictionary")
                For Each cel In rng
                    If Not dic.exists(cel.Value) Then
                        dic.Add cel.Value, Nothing
                    End If
                Next cel
                .Range("K" & lRow + 1) = dic.Count
                Set rng = .Range("M" & fRow & ":M" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("M" & lRow + 1) = rng(1)
                ElseIf rng.Count = WorksheetFunction.CountIf(rng, "") Then
                    .Range("M" & lRow + 1) = ""
                Else
                    .Range("M" & lRow + 1) = "Multiple"
                End If
                If y = 19 Then
                    y = 20
                Else
                    y = 19
                End If
            End With
        Next i
       
    End With
    Application.ScreenUpdating = True
End Sub

 

[hrayani]

Hi Mumps,
Bingo! Works Just Perfect
I have done a lot of tweaking with code you provided & everything is working just PERFECT

Here is the final code. Please check the red part containing the count unique value & guide me, is it the right way of doing it
What I did is, tell the code that if the unique count = 1 then just show rng(1) otherwise count unique & show units besides the count number
It is working as intended - but, still I would request you to check it & let me know if the approach is right ?

Sub copydata()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, x As Long, i As Long, fRow As Long, lRow As Long, y As Long: y = 19
    Set srcWS = Sheets("ORDERS")
    Set desWS = Sheets("RUNNING ORDER STATUS")
    
    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
    
    Rows("4:1000").EntireRow.Hidden = False
    Range("A4:Z1000").Clear
    
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter 22, "In Process"
        Intersect(.AutoFilter.Range, .Range("A:G,K:N,P:P")).Offset(1, 0).Copy desWS.Range("C4")
        .Range("A1").AutoFilter
    End With
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With desWS.Sort
        .SortFields.Clear
        
        .SortFields.Add Key:=Range("G3:G" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("M3:M" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D3:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("C3:N" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For x = LastRow To 5 Step -1
        With desWS
            
            If Range("H1").Value = "LEVEL 1" And .Cells(x, 7) <> .Cells(x - 1, 7) Then .Rows(x).EntireRow.Insert
            If Range("H1").Value = "LEVEL 2" And .Cells(x, 4) <> .Cells(x - 1, 4) Then .Rows(x).EntireRow.Insert
            If Range("H1").Value = "LEVEL 3" And .Cells(x, 4) <> .Cells(x - 1, 4) Then .Rows(x).EntireRow.Insert
            
            
        End With
    Next x
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With desWS.Range("G4:G" & LastRow).SpecialCells(xlCellTypeConstants)
        For i = 1 To .Areas.Count
            fRow = .Areas(i).Cells(1).Row
            lRow = .Areas(i).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            
With desWS

    .Range("C" & lRow + 1 & ":N" & lRow + 1).Value = .Range("C" & fRow & ":N" & fRow).Value
                
    .Range("K" & lRow + 1).Value = WorksheetFunction.Sum(.Range("K" & fRow & ":K" & lRow))
                
    .Range("B" & fRow & ":B" & lRow) = 1
    .Range("B" & fRow & ":N" & lRow).Interior.ColorIndex = y
    .Range("B" & fRow & ":N" & lRow).Interior.TintAndShade = 0.5
                
.Range("B" & lRow + 1) = 2
                
If Range("H1").Value = "LEVEL 1" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Interior.ColorIndex = y
If Range("H1").Value = "LEVEL 1" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Interior.TintAndShade = 0.5
If Range("H1").Value = "LEVEL 1" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Font.Bold = False
                
If Range("H1").Value = "LEVEL 2" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Interior.ColorIndex = y
If Range("H1").Value = "LEVEL 2" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Interior.TintAndShade = 0.5
If Range("H1").Value = "LEVEL 2" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Font.Bold = False
                
If Range("H1").Value = "LEVEL 3" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Interior.ColorIndex = 15
If Range("H1").Value = "LEVEL 3" Then .Range("B" & lRow + 1 & ":N" & lRow + 1).Font.Bold = True
                
                
    .Range("C" & fRow & ":N" & lRow).Borders(xlInsideVertical).Weight = xlThin
    .Range("C" & fRow & ":N" & lRow).Borders(xlInsideVertical).ColorIndex = 15
                
    .Range("C" & lRow + 1 & ":N" & lRow + 1).Borders(xlInsideVertical).Weight = xlThin
    .Range("C" & lRow + 1 & ":N" & lRow + 1).Borders(xlInsideVertical).ColorIndex = 15
    
'(START) Apply horizontal broders___________________________________________________

If Range("H1").Value = "LEVEL 1" Then
    .Range("C" & fRow & ":N" & lRow + 2).Borders(xlInsideHorizontal).Weight = xlThin
    .Range("C" & fRow & ":N" & lRow + 2).Borders(xlInsideHorizontal).ColorIndex = 15
End If
'(END) Apply horizontal broders_____________________________________________________
                
    Set rng = .Range("J" & fRow & ":J" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("J" & lRow + 1) = rng(1)
                Else
                    .Range("J" & lRow + 1) = "Multiple"
                End If
                
'    Set rng = .Range("L" & fRow & ":L" & lRow)
'                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
'                    .Range("L" & lRow + 1) = rng(1)
'                Else
'                    .Range("L" & lRow + 1) = "Multiple"
'                End If
                

[COLOR=rgb(235, 107, 86)][B]Set rng = .Range("L" & fRow & ":L" & lRow)
                Set dic = CreateObject("Scripting.Dictionary")
                For Each cel In rng
                    If Not dic.exists(cel.Value) Then
                        dic.Add cel.Value, Nothing
                    End If
                    Next cel
                .Range("L" & lRow + 1) = dic.Count & " Unit(s)"
             If .Range("L" & lRow + 1) = 1 & " Unit(s)" Then
                     .Range("L" & lRow + 1) = rng(1)
                End If[/B][/COLOR]
                
                
    Set rng = .Range("N" & fRow & ":N" & lRow)
                If rng.Count = WorksheetFunction.CountIf(rng, rng(1)) Then
                    .Range("N" & lRow + 1) = rng(1)
                ElseIf rng.Count = WorksheetFunction.CountIf(rng, "") Then
                    .Range("N" & lRow + 1) = ""
                Else
                    .Range("N" & lRow + 1) = "Multiple"
                End If
                
                If y = 19 Then
                    y = 20
                Else
                    y = 19
                End If
            End With
        Next i

    End With

    Application.ScreenUpdating = True
End Sub

 

[mumps]

If it works, then the approach is right.