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

 

[kvsrinivasamurthy]

Use the latest code.
After updating the data in sheet1 run macro once again. Sheet2 will have all the required from Sheet1.
During the process of macro run what is happening do not worry. See only final result.
If problem is not solved upload a sample file. showing the result.

 

[kvsrinivasamurthy]

Try this code. Names of sheets changed to RETSEL and result.

Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Dim Sh1, Sh2 As Worksheet
Set Sh1 = Sheets("RETSEL"): Set Sh2 = Sheets("result")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Sh2.Delete
On Error GoTo 0
Sh1.Copy After:=Sh1
ActiveSheet.Name = "result"
Lr = Range("B" & Rows.Count).End(xlUp).Row
col = 16777215
M = Filter(Evaluate("transpose(IF(RETSEL!B2:B" & Lr & "=""SUMMING"",Row(RETSEL!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]

Try this code also.

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

For T = UBound(M) To 0 Step -1
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
Application.DisplayAlerts = True
End Sub

 

[HaHoBe]

Hi kvsrinivasamurthy,

Sheet RETSEL on my sample workbook holds data up to row 10145.

#42 still will raise the very same error 1004 caused by Adr, breaking the code so no time is available.

#43 will run, time is 18,828125 sec (the times listed in #14 are based on the same data set but all codes keep sheet result not delete and copy data Sheet2/result and these are all close to 4 sec).

Again: all codes are run for the same data sheet (no matter how it is called): I wonder what I am doing wrong as your code was labelled to be the fastest of all by KalilMe.

Maybe you should update your userprofile.

Holger

 

[Peter_SSs]

I tested with about 4,500 rows and this was about 5 times faster than the post #43 code.
From what I can tell the results are the same.

Sub Copy_Blocks()
  Dim a As Variant
  Dim nc As Long, j As Long, rws As Long
  Dim rA As Range
  
  Dim tm As Double
  tm = Timer
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("result").Delete
  On Error Resume Next
  Application.DisplayAlerts = True
  Sheets.Add(After:=Sheets("RETSEL")).Name = "result"
  With Sheets("RETSEL")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    ReDim a(1 To .Range("E" & Rows.Count).End(xlUp).Row + 3, 1 To 1)
    For Each rA In .Range("E1", .Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
      rws = rA.Rows.Count + 3
      If Not rA.Cells(rws - 2, 4).Interior.Color = 16777215 Then
        For j = rA.Row To rA.Row + rws - 1
          a(j, 1) = 1
        Next j
      End If
    Next rA
    With .Cells(1, nc).Resize(UBound(a))
      .Value = a
      .SpecialCells(xlConstants).EntireRow.Copy Destination:=Sheets("result").Range("A1")
      .ClearContents
    End With
    Sheets("result").Cells(1, nc).Resize(UBound(a)).ClearContents
    Sheets("result").UsedRange.EntireColumn.AutoFit
  End With
  Application.ScreenUpdating = True
  MsgBox Format(Timer - tm, "0.00")
End Sub

 

[KalilMe]

@kvsrinivasamurthy based on post#43 all of thing are ok and I've found my mistake .
your code is really fast
thanks so much .

 

[KalilMe]

I tested with about 4,500 rows and this was about 5 times faster than the post #43 code.

are you sure?
I'm really surprised from that !!
in reality the code in post#43 is faster than code in post #45
I run the macro about more than 10 times for each code
code in post#43 gives from 0.110 to 0.120
code in post #45 gives from 0.200 to 0.220
In fact, you have a preference with the code compared to the code in post#43, because it copies without specifying where a SUMMING word is located, unlike the code in post #43 . If it was an error in its location, a problem with the code would occur. For this reason, I chose the mark for your solution. As for the speed, for me, it is not a big difference.
thanks Peter for your solution

 

[HaHoBe]

Hi KalilMe,

I was cuious and developped a workbook where all codes from this thread are covered and started from one procedure so that all work on the same dataset. I can assure you that Peter_SSs on this dataset is a lot faster than the praised code from #43.

Sub StartAllMacrosFormHere()

  Const cblnRun As Boolean = False

  dream_02
  MrE_1226327_05
  CopyData_07
  MrE_1226327_08
  MrE_1226327_17
  DataColoured_18
  If cblnRun Then DataColoured_23   'msgbox to avoid RTE for adding Sheet
  If cblnRun Then DataColoured_24   'error for this setup
  MrE_1226327_26
  If cblnRun Then DataColoured_27   'error for this setup
  If cblnRun Then DataColoured_33   'error for this setup
  If cblnRun Then DataColoured_35   'error for this setup
  If cblnRun Then DataColoured_39   'error for this setup
  If cblnRun Then DataColoured_42   'error for this setup
  DataColoured_43
  Copy_Blocks_45
 
End Sub

Result from the immediate window_

2,5859375 sec for procedure 'dream_02' by shinigamilight
1,9609375 sec for procedure 'MrE_1226327_05' by HaHoBe
2,46875 sec for procedure 'CopyData_07' by mumps
2,5390625 sec for procedure 'MrE_1226327_08' by HaHoBe
1 sec for procedure 'MrE_1226327_17' by HaHoBe - only copying values
2,3984375 sec for procedure 'DataColoured_18' by kvsrinivasamurthy - please check for areas copied to result
0,515625 sec for procedure 'MrE_1226327_26' by HaHoBes
12,359375 sec for procedure 'DataColoured_43' by kvsrinivasamurthy
1,43 sec for procedure 'Copy_Blocks_45' by Peter_SSs

Workbook maybe downloaded here, Size is 554 KB. Dataset goes up to Row 9934. Macros need to get started from IDE/MacroBox.

Added Code in Workbook_Open/DieseArbeitsmappe:

Private Sub Workbook_Open()
  With tblRemarks
    .Move After:=Worksheets(Worksheets.Count)
    .Activate
  End With
End Sub

Waiting for your results when running StartAllMacrosFormHere

Ciao,
Holger

 

[HaHoBe]

Update:

the formatting of time for PeterSSs wasn't correct, I altered the code to

  Application.ScreenUpdating = True
  Dim tmEnd As Double
  tmEnd = Timer
  Debug.Print tmEnd - tm & " sec for procedure 'Copy_Blocks_45' by Peter_SSs"

and got

0,390625 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,421875 sec for procedure 'Copy_Blocks_45' by Peter_SSs
0,390625 sec for procedure 'Copy_Blocks_45' by Peter_SSs

Holger

 

[KalilMe]

@HaHoBe

you're right about the speed for your file .
in reality I tested just post #26,43,45 (theses solve my requiremnts)
despite of you don't use borders and some colors like my file contains colors not just the headers also the lastrow contains color , even if that my testing is faster than you . this is strange!!
just guess , is the reason from using formulas in some ranges make slow the codes as you use that ?
actually I have not formulas at all on my file or OP . and I tested for 8000 rows for all of the codes .