Copy individual range based on highlighted last cell from sheet to another

[KalilMe]

Hello
I want copying for each range just contains higlighted cell in column H for the last row (SUMMING) from sheet to another
source data

Copy of TR.xlsm
	A	B	C	D	E	F	G	H
1					CODE
2					FR-00
3	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
4	1	01/01/2021	BANANA	FO	PL	200.00	12.00	2400.00
5	2	07/01/2021	BANANA	FO	PL	450.00	12.00	5400.00
6	3	08/01/2021	BANANA	FO	PL	500.00	19.57	9785.71
7	4	14/01/2021	BANANA	FO	PL	800.00	25.36	20285.71
8	5	15/01/2021	BANANA	FO	PL	850.00	26.32	22373.21
9		SUMMING				2800.00		60244.64
10
11
12					CODE
13					FR-01
14	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
15	1	02/01/2021	APPLE	FR	PPL	100.00	14.00	1400.00
16	2	09/01/2021	APPLE	FR	PPL	550.00	20.54	11294.64
17	3	16/01/2021	APPLE	FR	PPL	900.00	27.29	24557.14
18		SUMMING				1550.00		37251.79
19
20
21					CODE
22					FR-02
23	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
24	1	03/01/2021	PEACH	FR	LLP	300.00	15.00	4500.00
25	2	10/01/2021	PEACH	FR	LLP	600.00	21.50	12900.00
26	3	17/01/2021	PEACH	FR	LLP	950.00	28.25	26837.50
27		SUMMING				1850.00		44237.50
28
29
30					CODE
31					FR-03
32	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
33	1	04/01/2021	PEAR	FR	TTL	300.00	12.00	3600.00
34	2	11/01/2021	PEAR	FR	TTL	650.00	22.46	14601.79
35	3	18/01/2021	BANANA	FO	PL	1000.00	29.21	29214.29
36		SUMMING				1950.00		47416.07
37
38
39					CODE
40					FR-04
41	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
42	1	05/01/2021	STRWBERRAY	FR	MML	350.00	20.00	7000.00
43	2	12/01/2021	STRWBERRAY	FR	MML	700.00	23.43	16400.00
44	3	19/01/2021	APPLE	FR	PPL	1050.00	30.18	31687.50
45		SUMMING				2100.00		55087.50
RETSEL

result like this

Copy of TR.xlsm
	A	B	C	D	E	F	G	H
1					CODE
2					FR-00
3	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
4	1	01/01/2021	BANANA	FO	PL	200.00	12.00	2400.00
5	2	07/01/2021	BANANA	FO	PL	450.00	12.00	5400.00
6	3	08/01/2021	BANANA	FO	PL	500.00	19.57	9785.71
7	4	14/01/2021	BANANA	FO	PL	800.00	25.36	20285.71
8	5	15/01/2021	BANANA	FO	PL	850.00	26.32	22373.21
9		SUMMING				2800.00		60244.64
10
11
12					CODE
13					FR-02
14	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
15	1	03/01/2021	PEACH	FR	LLP	300.00	15.00	4500.00
16	2	10/01/2021	PEACH	FR	LLP	600.00	21.50	12900.00
17	3	17/01/2021	PEACH	FR	LLP	950.00	28.25	26837.50
18		SUMMING				1850.00		44237.50
19
20
21					CODE
22					FR-04
23	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
24	1	05/01/2021	STRWBERRAY	FR	MML	350.00	20.00	7000.00
25	2	12/01/2021	STRWBERRAY	FR	MML	700.00	23.43	16400.00
26	3	19/01/2021	APPLE	FR	PPL	1050.00	30.18	31687.50
27		SUMMING				2100.00		55087.50
result

note: the data are increasable and changeable in sheet RETSEL

 

[KalilMe]

should replace already existing data in sheet2.

 

[HaHoBe]

Hi kvsrinivasamurthy,

Code from #23 modified:

Sub DataColoured2()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M
Dim dblStart As Double
Dim dblEnd As Double

dblStart = Timer
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "DataColoured2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
  If Range("H" & M(T)).Interior.Color <> col Then
    With Range("H" & M(T)).CurrentRegion
      .Resize(.Rows.Count + 2).Delete Shift:=xlUp
    End With
  End If
Next T
Application.ScreenUpdating = True
dblEnd = Timer

Debug.Print "elapsed time for procedure 'DataColoured2': " & dblEnd - dblStart & " sec"
End Sub

brings up this (only a part):

MrE_1226327_1700A0F_copy individual rang_230110.xlsm
	A	B	C	D	E	F	G	H
98					CODE
99					FR-00175
100	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	TOTAL
101	1	44200	PEAR	FR	TTL	300	12	3600
102	2	44207	PEAR	FR	TTL	650	224.642.857.142.857	146.017.857.142.857
103	3	44214	BANANA	FO	PL	1000	292.142.857.142.857	292.142.857.142.857
104		SUMMING				1950		474.160.714.285.714
105
106								TOTAL
107					CODE			7000
108					FR-00184			164.000.000.000.001
109	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	316.875.000.000.001
110	1	44201	STRWBERRAY	FR	MML	350	20	550.875.000.000.001
111	2	44208	STRWBERRAY	FR	MML	700	234.285.714.285.715
112	3	44215	APPLE	FR	PPL	1050	301.785.714.285.715
113		SUMMING				2100
114
115					CODE			1400
116					FR-00204			112.946.428.571.429
117	ITEM	DATE	GOODS	TYPE	PR	QTY	UNIT	245.571.428.571.429
118	1	44198	APPLE	FR	PPL	100	14	372.517.857.142.857
119	2	44205	APPLE	FR	PPL	550	205.357.142.857.143
120	3	44212	APPLE	FR	PPL	900	272.857.142.857.143
121		SUMMING				1550
DataColoured2

elapsed time for procedure 'DataColoured2': 35,08203125 sec

What am I doing wrong?

Holger

 

[kvsrinivasamurthy]

Try

Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Sheet2").Delete
On Error GoTo 0
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "Sheet2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color <> col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp  
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[kvsrinivasamurthy]

Ref Post#32.
Sorry. I don't know.

 

[kvsrinivasamurthy]

Slight change in code

Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Sheet2").Delete
On Error GoTo 0
Sheets("Sheet1").Copy After:=Sheets("Sheet1")
ActiveSheet.Name = "Sheet2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = Range("h9").Interior.Color
M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color <> col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp   'Adr = Mid(Adr, 2):
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[HaHoBe]

Hi kvsrinivasamurthy,

OP claims to have about 8k of rows, the testsheet I used to compare the codes goes up to row 10145.

Maybe it's the length of the string Adr (I think to remember about a limit for any string for a range). Immediate Window shows

contents of Adr: ,$A$12:$H$20,$A$30:$H$38,$A$59:$H$70,$A$80:$H$88,$A$109:$H$117,$A$127:$H$135,$A$156:$H$164,$A$174:$H$182,$A$203:$H$211,$A$221:$H$229,$A$250:$H$258,$A$268:$H$276,$A$297:$H$305,$A$315:$H$323,$A$344:$H$352,$A$362:$H$370,$A$391:$H$399,$A$409:$H$417,$A$438:$H$446,$A$456:$H$464,$A$485:$H$493,$A$503:$H$511,$A$532:$H$540,$A$550:$H$558,$A$579:$H$587,$A$597:$H$605,$A$626:$H$634,$A$644:$H$652,$A$673:$H$681,$A$691:$H$699,$A$720:$H$728,$A$738:$H$746,$A$767:$H$775,$A$785:$H$793,$A$814:$H$822,$A$832:$H$840,$A$861:$H$869,$A$879:$H$887,$A$908:$H$916,$A$926:$H$934,$A$955:$H$963,$A$973:$H$981,$A$1002:$H$1010,$A$1020:$H$1028,$A$1049:$H$1057,$A$1067:$H$1075,$A$1096:$H$1104,$A$1114:$H$1122,$A$1143:$H$1151,$A$1161:$H$1169,$A$1190:$H$1198,$A$1208:$H$1216,$A$1237:$H$1245,$A$1255:$H$1263,$A$1284:$H$1292,$A$1302:$H$1310,$A$1331:$H$1339,$A$1349:$H$1357,$A$1378:$H$1386,$A$1396:$H$1404,$A$1425:$H$1433,$A$1443:$H$1451,$A$1472:$H$1480,$A$1490:$H$1498,$A$1519:$H$1527,$A$1537:$H$1545,$A$1566:$H$1574,$A$1584:$H$1592,$A$1613:$
H$1621,$A$1631:$H$1639,$A$1660:$H$1668,$A$1678:$H$1686,$A$1706:$H$1714,$A$1724:$H$1732,$A$1753:$H$1761,$A$1771:$H$1779,$A$1800:$H$1808,$A$1818:$H$1826,$A$1847:$H$1855,$A$1865:$H$1873,$A$1894:$H$1902,$A$1912:$H$1920,$A$1941:$H$1949,$A$1959:$H$1967,$A$1988:$H$1996,$A$2006:$H$2014,$A$2035:$H$2043,$A$2053:$H$2061,$A$2082:$H$2090,$A$2100:$H$2108,$A$2129:$H$2137,$A$2147:$H$2155,$A$2176:$H$2184,$A$2194:$H$2202,$A$2223:$H$2231,$A$2241:$H$2249,$A$2270:$H$2278,$A$2288:$H$2296,$A$2317:$H$2325,$A$2335:$H$2343,$A$2364:$H$2372,$A$2382:$H$2390,$A$2411:$H$2419,$A$2429:$H$2437,$A$2458:$H$2466,$A$2476:$H$2484,$A$2505:$H$2513,$A$2523:$H$2531,$A$2552:$H$2560,$A$2570:$H$2578,$A$2599:$H$2607,$A$2617:$H$2625,$A$2646:$H$2654,$A$2664:$H$2672,$A$2693:$H$2701,$A$2711:$H$2719,$A$2740:$H$2748,$A$2758:$H$2766,$A$2787:$H$2795,$A$2805:$H$2813,$A$2834:$H$2842,$A$2852:$H$2860,$A$2881:$H$2889,$A$2899:$H$2907,$A$2928:$H$2936,$A$2946:$H$2954,$A$2975:$H$2983,$A$2993:$H$3001,$A$3022:$H$3030,$A$3040:$H$3048,$A$3069:$H$3077,$A$3087:$H$3095,$A$3116:
$H$3124,$A$3134:$H$3142,$A$3163:$H$3171,$A$3181:$H$3189,$A$3210:$H$3218,$A$3228:$H$3236,$A$3257:$H$3265,$A$3275:$H$3283,$A$3304:$H$3312,$A$3322:$H$3330,$A$3351:$H$3359,$A$3369:$H$3377,$A$3398:$H$3406,$A$3416:$H$3424,$A$3445:$H$3453,$A$3463:$H$3471,$A$3492:$H$3500,$A$3510:$H$3518,$A$3539:$H$3547,$A$3557:$H$3565,$A$3586:$H$3594,$A$3604:$H$3612,$A$3633:$H$3641,$A$3651:$H$3659,$A$3680:$H$3688,$A$3698:$H$3706,$A$3727:$H$3735,$A$3745:$H$3753,$A$3774:$H$3782,$A$3792:$H$3800,$A$3821:$H$3829,$A$3839:$H$3847,$A$3868:$H$3876,$A$3886:$H$3894,$A$3915:$H$3923,$A$3933:$H$3941,$A$3962:$H$3970,$A$3980:$H$3988,$A$4009:$H$4017,$A$4027:$H$4035,$A$4056:$H$4064,$A$4074:$H$4082,$A$4103:$H$4111,$A$4121:$H$4129,$A$4150:$H$4158,$A$4168:$H$4176,$A$4197:$H$4205,$A$4215:$H$4223,$A$4244:$H$4252,$A$4262:$H$4270,$A$4291:$H$4299,$A$4309:$H$4317,$A$4338:$H$4346,$A$4356:$H$4364,$A$4385:$H$4393,$A$4403:$H$4411,$A$4432:$H$4440,$A$4450:$H$4458,$A$4479:$H$4487,$A$4497:$H$4505,$A$4526:$H$4534,$A$4544:$H$4552,$A$4573:$H$4581,$A$4591:$H$4599,$A$4620
:$H$4628,$A$4638:$H$4646,$A$4667:$H$4675,$A$4685:$H$4693,$A$4714:$H$4722,$A$4732:$H$4740,$A$4761:$H$4769,$A$4779:$H$4787,$A$4808:$H$4816,$A$4826:$H$4834,$A$4855:$H$4863,$A$4873:$H$4881,$A$4902:$H$4910,$A$4920:$H$4928,$A$4949:$H$4957,$A$4967:$H$4975,$A$4996:$H$5004,$A$5014:$H$5022,$A$5043:$H$5051,$A$5061:$H$5069,$A$5090:$H$5098,$A$5108:$H$5116,$A$5137:$H$5145,$A$5155:$H$5163,$A$5184:$H$5192,$A$5202:$H$5210,$A$5231:$H$5239,$A$5249:$H$5257,$A$5278:$H$5286,$A$5296:$H$5304,$A$5325:$H$5333,$A$5343:$H$5351,$A$5372:$H$5380,$A$5390:$H$5398,$A$5419:$H$5427,$A$5437:$H$5445,$A$5466:$H$5474,$A$5484:$H$5492,$A$5513:$H$5521,$A$5531:$H$5539,$A$5560:$H$5568,$A$5578:$H$5586,$A$5607:$H$5615,$A$5625:$H$5633,$A$5654:$H$5662,$A$5672:$H$5680,$A$5701:$H$5709,$A$5719:$H$5727,$A$5748:$H$5756,$A$5766:$H$5774,$A$5795:$H$5803,$A$5813:$H$5821,$A$5842:$H$5850,$A$5860:$H$5868,$A$5889:$H$5897,$A$5907:$H$5915,$A$5936:$H$5944,$A$5954:$H$5962,$A$5983:$H$5991,$A$6001:$H$6009,$A$6030:$H$6038,$A$6048:$H$6056,$A$6077:$H$6085,$A$6095:$H$6103,$A$612
4:$H$6132,$A$6142:$H$6150,$A$6171:$H$6179,$A$6189:$H$6197,$A$6217:$H$6225,$A$6235:$H$6243,$A$6264:$H$6272,$A$6282:$H$6290,$A$6311:$H$6319,$A$6329:$H$6337,$A$6358:$H$6366,$A$6376:$H$6384,$A$6405:$H$6413,$A$6423:$H$6431,$A$6452:$H$6460,$A$6470:$H$6478,$A$6499:$H$6507,$A$6517:$H$6525,$A$6546:$H$6554,$A$6564:$H$6572,$A$6593:$H$6601,$A$6611:$H$6619,$A$6640:$H$6648,$A$6658:$H$6666,$A$6687:$H$6695,$A$6705:$H$6713,$A$6734:$H$6742,$A$6752:$H$6760,$A$6781:$H$6789,$A$6799:$H$6807,$A$6828:$H$6836,$A$6846:$H$6854,$A$6875:$H$6883,$A$6893:$H$6901,$A$6922:$H$6930,$A$6940:$H$6948,$A$6969:$H$6977,$A$6987:$H$6995,$A$7016:$H$7024,$A$7034:$H$7042,$A$7063:$H$7071,$A$7081:$H$7089,$A$7110:$H$7118,$A$7128:$H$7136,$A$7157:$H$7165,$A$7175:$H$7183,$A$7204:$H$7212,$A$7222:$H$7230,$A$7251:$H$7259,$A$7269:$H$7277,$A$7298:$H$7306,$A$7316:$H$7324,$A$7344:$H$7352,$A$7362:$H$7370,$A$7391:$H$7399,$A$7409:$H$7417,$A$7438:$H$7446,$A$7456:$H$7464,$A$7485:$H$7493,$A$7503:$H$7511,$A$7532:$H$7540,$A$7550:$H$7558,$A$7579:$H$7587,$A$7597:$H$7605,$A$76
26:$H$7634,$A$7644:$H$7652,$A$7673:$H$7681,$A$7691:$H$7699,$A$7720:$H$7728,$A$7738:$H$7746,$A$7767:$H$7775,$A$7785:$H$7793,$A$7814:$H$7822,$A$7832:$H$7840,$A$7861:$H$7869,$A$7879:$H$7887,$A$7907:$H$7915,$A$7925:$H$7933,$A$7954:$H$7962,$A$7972:$H$7980,$A$8001:$H$8009,$A$8019:$H$8027,$A$8048:$H$8056,$A$8066:$H$8074,$A$8095:$H$8103,$A$8113:$H$8121,$A$8142:$H$8150,$A$8160:$H$8168,$A$8189:$H$8197,$A$8207:$H$8215,$A$8236:$H$8244,$A$8254:$H$8262,$A$8283:$H$8291,$A$8301:$H$8309,$A$8330:$H$8338,$A$8348:$H$8356,$A$8377:$H$8385,$A$8395:$H$8403,$A$8424:$H$8432,$A$8442:$H$8450,$A$8470:$H$8478,$A$8488:$H$8496,$A$8517:$H$8525,$A$8535:$H$8543,$A$8564:$H$8572,$A$8582:$H$8590,$A$8611:$H$8619,$A$8629:$H$8637,$A$8658:$H$8666,$A$8676:$H$8684,$A$8705:$H$8713,$A$8723:$H$8731,$A$8752:$H$8760,$A$8770:$H$8778,$A$8799:$H$8807,$A$8817:$H$8825,$A$8846:$H$8854,$A$8864:$H$8872,$A$8893:$H$8901,$A$8911:$H$8919,$A$8940:$H$8948,$A$8958:$H$8966,$A$8987:$H$8995,$A$9005:$H$9013,$A$9034:$H$9042,$A$9052:$H$9060,$A$9081:$H$9089,$A$9099:$H$9107,$A$9
128:$H$9136,$A$9146:$H$9154,$A$9175:$H$9183,$A$9193:$H$9201,$A$9222:$H$9230,$A$9240:$H$9248,$A$9269:$H$9277,$A$9287:$H$9295,$A$9316:$H$9324,$A$9334:$H$9342,$A$9363:$H$9371,$A$9381:$H$9389,$A$9410:$H$9418,$A$9428:$H$9436,$A$9457:$H$9465,$A$9475:$H$9483,$A$9504:$H$9512,$A$9522:$H$9530,$A$9551:$H$9559,$A$9569:$H$9577,$A$9598:$H$9606,$A$9616:$H$9624,$A$9645:$H$9653,$A$9663:$H$9671,$A$9692:$H$9700,$A$9710:$H$9718,$A$9739:$H$9747,$A$9757:$H$9765,$A$9786:$H$9794,$A$9804:$H$9812,$A$9833:$H$9841,$A$9851:$H$9859,$A$9880:$H$9888,$A$9898:$H$9906,$A$9927:$H$9935,$A$9945:$H$9953,$A$9974:$H$9982,$A$9992:$H$10000,$A$10021:$H$10029,$A$10039:$H$10047,$A$10068:$H$10076,$A$10086:$H$10094,$A$10115:$H$10123,$A$10133:$H$10141
length of signs in Adr: 6833

RTE raised is 1004 like stated by kalilMe earlier on.

Holger

 

[KalilMe]

@kvsrinivasamurthy
there is problem for all of your codes sorry I said that !
I've found out latey because I have big data and I don't expect showing this problem . based on your code you don't specify the color just you depend on the highlighted cell, but if there is the cell is not highlighted in SUMMING last row for column H also will copy !
BTW in last code gives error mismatch in this line

M = Filter(Evaluate("transpose(IF(Sheet1!B2:B" & Lr & "=""SUMMING"",Row(Sheet1!B2:B" & Lr & "),False))"), False, False)

thanks again

 

[kvsrinivasamurthy]

The error mismatch may be In column B there is no cell containing "SUMMING".

 

[kvsrinivasamurthy]

Try. This code reads only those ranges For which H cell is not colored (Irrespective of any color) and deletes those ranges.

Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Sheet2").Delete
On Error GoTo 0
Sheets("Sheet1").Copy After:=Sheets("Sheet1")
ActiveSheet.Name = "Sheet2"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = 16777215
M = Filter(Evaluate("transpose(IF(Sheet2!B2:B" & Lr & "=""SUMMING"",Row(Sheet2!B2:B" & Lr & "),False))"), False, False)

For T = 0 To UBound(M)
If Range("H" & M(T)).Interior.Color = col Then
With Range("H" & M(T)).CurrentRegion
Adr = Adr & "," & .Resize(.Rows.Count + 2).Address
End With
End If
Next T
If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[KalilMe]

@kvsrinivasamurthy

from the first time the code works as what I want , but if update data in sheet1 , then should update data in sheet2 without any problem , but this is not what happens . it shows ths same problem as in post#37 (also copy not highlighted cells)

after copying highlighted data to sheet2 and return to sheet1 to delete the color for range For which H , then should update in sheet2 by delete the whole range becomes no color ,and if change range For which H from not highlighted to highlighted range For which H in sheet1 then should add to sheet2
so any updating in sheet1 should also updating in sheet2 .
should replace data in sheet2 every time run the macro .