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]

@HaHoBe
thanks again your code gives about 1.00 sec for me yes this is really fast than before ,but you ignore formatting
that's why your code is faster than Kvsrinivasamurthy . shouldn't ignore formatting .

​

 

[KalilMe]

@kvsrinivasamurthy this is better
it gives about 3.0566
thanks . if you could achieve to reach 1.00 sec with formatting will be great .

 

[kvsrinivasamurthy]

Try this code. Let us know How much time this code takes.
Code creates new sheet "Sheet2New"

Sub DataColoured()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "Sheet2New"
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
End Sub

 

[kvsrinivasamurthy]

Try this code also. Let us know How much time this code takes.
Code creates new sheet "Sheet3New"

Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Name = "Sheet3New"
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 Adr = Mid(Adr, 2)
Range(Adr).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

 

[KalilMe]

@kvsrinivasamurthy
Code in post#23 gives 1.10
Code in post#24 gives error method range of object _global failed n this line

Range(Adr).Delete Shift:=xlUp

about after add new sheet , can you make just updtating data for the added new sheet instead of shows error when run the macro every time please?

 

[HaHoBe]

Hi KalilMe,

Public Sub MrE_1226327_1700B0B()

' https://www.mrexcel.com/board/threads/copy-individual-range-based-on-highlighted-last-cell-from-sheet-to-another.1226327/

Dim wsTarg As Worksheet
Dim wsData As Worksheet
Dim lngStart As Long
Dim rngWork As Range
Dim rngTarg As Range
Dim dblStart As Double
Dim dblEnd As Double

dblStart = Timer

'change sheetnames to suit
Set wsData = Worksheets("SpeedTest")
Set wsTarg = Worksheets("result")
lngStart = 1

wsTarg.Range("A1:N1").EntireColumn.Delete

Application.ScreenUpdating = False
With wsData
  Do While lngStart < .Cells(.Rows.Count, "B").End(xlUp).Row
    Set rngTarg = .Cells(lngStart, "E").CurrentRegion
    With rngTarg
      If .Range("H" & .Rows.Count).Interior.Color = 52377 Then
        If rngWork Is Nothing Then
          Set rngWork = rngTarg.Resize(rngTarg.Rows.Count + 2)
        Else
          Set rngWork = Union(rngWork, rngTarg.Resize(rngTarg.Rows.Count + 2))
        End If
      End If
      lngStart = .Cells(.Rows.Count, .Columns.Count).End(xlDown).Row
    End With
  Loop
End With

With wsTarg
  rngWork.Copy wsTarg.Cells(1, 1)
  .Range("A1:H1").EntireColumn.AutoFit
  Application.Goto .Range("A1"), True
End With

dblEnd = Timer

Debug.Print "elapsed time for procedure 'MrE_1226327_1700B0B': " & dblEnd - dblStart & " sec"

Application.ScreenUpdating = False
Set rngWork = Nothing
Set rngTarg = Nothing
Set wsTarg = Nothing
Set wsData = Nothing

End Sub

elapsed time for procedure 'MrE_1226327_1700B0B': 0,859375 sec

Holger

 

[kvsrinivasamurthy]

I have removed the name for new sheet. If required pl change the name of the sheet manually.
I am not getting error while running macro. If problem is still there Pl upload file.

Sub DataColoured3()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M, Adr
Application.ScreenUpdating = False
Sheets("Sheet1").Copy Before:=Sheets(1)
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 Adr = Mid(Adr, 2): Range(Adr).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

 

[KalilMe]

@HaHoBe
awesome !
gives 0.480 sec seems @kvsrinivasamurthy's code is faster than you .

 

[KalilMe]

@kvsrinivasamurthy
magnificent !
gives 0.110 sec

I have removed the name for new sheet. If required pl change the name of the sheet manually

I don't need add new sheet every time when I run macro every time , just work at the sheet has already added . could be ,please?.

 

[kvsrinivasamurthy]

You mean every time you want add new data to sheet2 along with already existing data or replace already existing data in sheet2.