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

 

[Peter_SSs]

Waiting for your results when running StartAllMacrosFormHere

I don't know what it is, but seems to be something funny happening with that StartAllMacrosFormHere procedure.
I went through all the individual procedures and added a line to write the timer results (number only) to the Remarks sheet col M immediately after the Debug.Print line and then ran the StartAllMacrosFormHere procedure.
I manually moved those results from col M to col L and then went back and ran each of the procedures individually, still with the results going to 'Remarks' col M
Below are my results. You wouldn't expect the results to be identical but it looks like there could be something unusual with the second procedure and something definitely unusual with the final one.

Copy Ranges Test WB AnySheet230112.xlsm
	L	M	N
1	StartAllMacrosFormHere	Individual Procedures
2	2.23	2.38	106.73%
3	1.87	1.06	56.68%
4	2.46	2.33	94.72%
5	2.44	2.36	96.72%
6	0.48	0.59	122.92%
7	2.19	2.23	101.83%
8	0.23	0.26	113.04%
9	8.51	7.5	88.13%
10	2.11	0.19	9.00%
Remarks

Cell Formulas
Range	Formula
N2:N10	N2	=M2/L2

 

[HaHoBe]

Hi PeterSSs,

all I can do is confirm what you point out.

Running your code alone brings up

0,44140625 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,375 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,44140625 sec for procedure 'Copy_Blocks_45' by Peter_SSs

while last position in caller (all kvsrinivasamurthy codes except DataColoured_43 deactivated)

1,5390625 sec for procedure 'Copy_Blocks_45' by Peter_SSs

Running only these two codes from caller:

0,51953125 sec for procedure 'MrE_1226327_26' by HaHoBe
0,36328125 sec for procedure 'Copy_Blocks_45' by Peter_SSs

First of all I can only state that your code is the fastest provided no matter what the lines in the Immediate Window or on the sheet say. And times (if less than one second) should be monitored by something else than Timer (but I wonder if that would be worth altering the code if available when you have the feeling the code is doing the job properly and fast enough for you).

Holger

 

[Peter_SSs]

but I wonder if that would be worth altering the code if available when you have the feeling the code is doing the job properly and fast enough for you

I agree. Use the code that you are most comfortable with if you are happy with the accuracy and speed.

Thanks for double-checking the different timings though.

 

[HaHoBe]

There is only one thing left open for me.

In #23 kvsrinivasamurthy posted code which was marked to raise a run-time error 1004 by KalilMe in #24 and by me in #36 (with number of rows checked and a dump of the immediate window). Using the absolute addresses will not really be of help as that means 4 extra characters per Address for the $

In fact it seems that range can only take a string with a length of 256 characters (using Select here is just for demonstration), strAdr1 for the second loop will raise the error:

Sub TestRangeLimitString()
Dim strAdr1 As String
Dim lngCnt As Long
Dim lngLoop As Long
Dim lngStep As Long
Dim strAdr2 As String

For lngLoop = 1 To 2
  strAdr1 = vbNullString
  strAdr2 = vbNullString
  lngStep = 10 - lngLoop
  For lngCnt = 1 To 180 Step lngStep
    strAdr1 = strAdr1 & Range(Cells(lngCnt, 1), Cells(lngCnt + 5, 8)).Address & ","
    strAdr2 = strAdr2 & Range(Cells(lngCnt, 1), Cells(lngCnt + 5, 8)).Address(0, 0) & ","
  Next lngCnt
  Debug.Print "length of string2: " & Len(strAdr2) & vbCrLf & Left(strAdr2, Len(strAdr2) - 1)
  Range(Left(strAdr2, Len(strAdr2) - 1)).Select
  Debug.Print "length of string1: " & Len(strAdr1) & vbCrLf & Left(strAdr1, Len(strAdr1) - 1)
  Range(Left(strAdr1, Len(strAdr1) - 1)).Select
Next lngLoop
End Sub

On the DataSet I used in the sample sheet (FR-001 to FR750) the codes with a similar codeline like If Adr <> "" Then Range(Mid(Adr, 2)).Delete Shift:=xlUp work if the relative address is used for FR-001 to FR-039 (A1:H511).

Holger