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

 

[HaHoBe]

Hi KalilMe,

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

'Assumptions: Code-Nr to transfer to is located on Column E in the second row of the area to work on
'             "SUMMING" is in capital letter and located on Column B in the last row of the area to work on
'             ColorIndex for highlighting is vbYellow or 6
'             Value to transfer is located on Column H in the last row of the area to work on

'changed the color to check from 6 (vbYellow) to 52377

Dim wsTarg As Worksheet
Dim wsData As Worksheet
Dim lngStart As Long
Dim lngCopy As Long
Dim rngWork As Range
Dim rngTarg As Range
Dim rngHit As Range

'change sheetbames to suit
Set wsData = Worksheets("RETSEL")
Set wsTarg = Worksheets("result")
lngStart = 1
lngCopy = 1

Application.ScreenUpdating = False
With wsData
  Do While lngStart < .Cells(.Rows.Count, "B").End(xlUp).Row
    Set rngWork = .Cells(lngStart, "E").CurrentRegion
    With rngWork
      If .Range("B" & .Rows.Count).Value = "SUMMING" And _
          .Range("H" & .Rows.Count).Interior.Color = 52377 Then
        .Copy wsTarg.Cells(lngCopy, 1)
        lngCopy = wsTarg.Cells(wsTarg.Rows.Count, "H").End(xlUp).Row + 3
      End If
      lngStart = .Cells(.Rows.Count, .Columns.Count).End(xlDown).Row
    End With
  Loop
End With

With Sheets("result")
  .Range("A1:H1").EntireColumn.AutoFit
  Application.Goto .Range("A1")
End With

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

End Sub

Holger

 

[KalilMe]

@HaHoBe
finally works but not as what I want.
first is still slow like @shinigamilight
second your code repeats copying to the bottom when run the macro everytime .
It should just replace when update data. I mean clear in sheet result before bring data.
Thanks for your trying.

 

[HaHoBe]

Hi KalilMe,

please define slow. Have you ever considered your data setup to be a possible reason for the runtime of the provided codes?

On a test the Immediate Window brought up this when a timer had been used:

elapsed time for procedure: 4,126953125 sec
last row to check: 10.145

How fast do you think the procedure should be?


Regarding the multiple use of the procedure just add one line of code like

lngCopy = 1

'delete data on sheet result
wsTarg.Range("A1:N1").EntireColumn.Delete

Application.ScreenUpdating = False

And I really wonder as this has never been mentioned before as it has not been part of any code supplied.

Holger

 

[HaHoBe]

Knowing that it relies on the computer used, Standalone or Network, OS, Processor, RAM, Applications running, HDD I wanted to know about the times for the 3 different codes supplied on my computer (Laptop Standalone no Network, Windows11, 8 GB RAM, Shared Memory Graphics, OS, Internet Securoty, InternetConnection, FireFox, Excel2019):

elapsed time for procedure 'dream': 3,95703125 sec
elapsed time for procedure 'MrE_1226327_1700811_mod03': 3,921875 sec
elapsed time for procedure 'CopyData': 3,921875 sec
----
elapsed time for procedure 'MrE_1226327_1700811_mod03': 4,09765625 sec
elapsed time for procedure 'CopyData': 3,95703125 sec
elapsed time for procedure 'dream': 3,89453125 sec
----
elapsed time for procedure 'CopyData': 3,94921875 sec
elapsed time for procedure 'dream': 3,90625 sec
elapsed time for procedure 'MrE_1226327_1700811_mod03': 3,90625 sec

I modified the codes supplied to delete any content on sheet "result" and implemented the timer. In "dream" I added the object to the worksheet "RETSEL" for lr and disabled ScreenUpdating for running of the code (changedk to be of Type Long as lr is of that Type). The difference of 0.02 seconds does not point out which code is fastest (I would choose any of the other codes as they are much shorter than mine).

Holger

 

[KalilMe]

@HaHoBe
this is what I got
macro dream is 10.3 sec
macro CopyData is 6.8
macro MrE_1226327_1700811_mod02 is 7.2
so nobody using at least (array & dic) to make fast I believe it can achieve to reach 2.5 is acceptable
thanks for all

 

[HaHoBe]

Hi KalilMe,

as you know how to solve the problem I would be glad to learn how to integrate the background color into either array or dictionary. Please let me know - I'm old but still trying to learn new tricks.

Holger

 

[HaHoBe]

Hi KalilMe,

my remarks above where meant to transfer the setup without any change to an array. If I enter another column (showing the color of the cells in the last column of the original data) a code like the following should work:

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

' using Arrays to copy over the values
' prior to assigning the range to the array a new column will be inserted to the right:
'     reading out the color for the last column of original data by UDF
' additional column will be deleted at end of procedure

Dim dblStart As Double
Dim dblEnd As Double

Dim lngStart As Long
Dim lngEnd As Long
Dim lngLast As Long
Dim lngNewCol As Long
Dim lngLoop As Long
Dim lngVar As Long
Dim lngWrite As Long
Dim lngCnt As Long

Dim arr() As Variant
Dim var() As Variant

Dim wsTest As Worksheet
Dim wsTarg As Worksheet
Dim wsData As Worksheet

Application.ScreenUpdating = False
dblStart = Timer

'please adjust the sheetnames
Set wsData = Worksheets("SPEEDTEST")
Set wsTarg = Worksheets("result")

wsTarg.Cells.Delete

With wsData
  lngLast = .Cells(.Rows.Count, "H").End(xlUp).Row
  lngNewCol = .Cells(3, .Columns.Count).End(xlToLeft).Column + 1
  
  .Cells(1, lngNewCol).EntireColumn.Insert
  With .Range(.Cells(1, lngNewCol), .Cells(lngLast, lngNewCol))
    .FormulaR1C1 = "=fncCellInteriorColor(RC[-1])"
    .Value = .Value
  End With
  
  arr = .Range("A1", .Cells(lngLast, lngNewCol)).Value
  
  For lngCnt = 1 To UBound(arr, 1)
    If arr(lngCnt, lngNewCol) = 65535 Then
      lngStart = lngCnt - 2
    ElseIf arr(lngCnt, lngNewCol) = 52377 Then
      lngEnd = lngCnt
      ReDim var(lngEnd - lngStart + 2, 8)
      lngWrite = 0
      For lngLoop = lngStart To lngEnd
        lngWrite = lngWrite + 1
        For lngVar = 1 To 8
          var(lngWrite, lngVar - 1) = arr(lngLoop, lngVar)
        Next lngVar
      Next lngLoop
      wsTarg.Cells(wsTarg.Rows.Count, 1).End(xlUp).Offset(3).Resize(UBound(var), 8).Value = var
      Erase var
    End If
  Next lngCnt
  .Cells(1, lngNewCol).EntireColumn.Delete
End With
With wsTarg
  .Range("A1").Resize(4).EntireRow.Delete
  .Range("A1:H1").EntireColumn.AutoFit
  Application.Goto .Range("A1"), True
End With

dblEnd = Timer
Application.ScreenUpdating = True

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

End Sub

Function fncCellInteriorColor(rng As Range) As Long
  fncCellInteriorColor = rng.Interior.Color
End Function

I haven't found a way to access the rows of the orignal array at once so another array is used and filled via loop (I know: old, learning nothing new and rusty). On Worksheets("SPEEDTEST") going up to row 10145 timer showed

elapsed time for procedure 'MrE_1226327_1700A0F': 0,75390625 sec

Please make sure that the UDF is copied over as well (in my test both were located in the same module) and that there is only one function of that name present in the workbook.

Holger

 

[kvsrinivasamurthy]

Try this this faster.

Sub DataColoured()
Dim col As Long, Lr As Long, T As Long, Ro As Long
Dim M
Application.ScreenUpdating = False
With Sheets("Sheet1")
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)
Sheets("Sheet2").Cells.Clear
For T = 0 To UBound(M)
If .Range("H" & M(T)).Interior.Color = col Then
If T = 0 Then Ro = 0 Else Ro = 5
.Range("H" & M(T)).CurrentRegion.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(Ro, 0)
End If
Next T
End With
Application.ScreenUpdating = True
End Sub

 

[shinigamilight]

Hi KalilMe,

my remarks above where meant to transfer the setup without any change to an array. If I enter another column (showing the color of the cells in the last column of the original data) a code like the following should work:

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

' using Arrays to copy over the values
' prior to assigning the range to the array a new column will be inserted to the right:
'     reading out the color for the last column of original data by UDF
' additional column will be deleted at end of procedure

Dim dblStart As Double
Dim dblEnd As Double

Dim lngStart As Long
Dim lngEnd As Long
Dim lngLast As Long
Dim lngNewCol As Long
Dim lngLoop As Long
Dim lngVar As Long
Dim lngWrite As Long
Dim lngCnt As Long

Dim arr() As Variant
Dim var() As Variant

Dim wsTest As Worksheet
Dim wsTarg As Worksheet
Dim wsData As Worksheet

Application.ScreenUpdating = False
dblStart = Timer

'please adjust the sheetnames
Set wsData = Worksheets("SPEEDTEST")
Set wsTarg = Worksheets("result")

wsTarg.Cells.Delete

With wsData
  lngLast = .Cells(.Rows.Count, "H").End(xlUp).Row
  lngNewCol = .Cells(3, .Columns.Count).End(xlToLeft).Column + 1
 
  .Cells(1, lngNewCol).EntireColumn.Insert
  With .Range(.Cells(1, lngNewCol), .Cells(lngLast, lngNewCol))
    .FormulaR1C1 = "=fncCellInteriorColor(RC[-1])"
    .Value = .Value
  End With
 
  arr = .Range("A1", .Cells(lngLast, lngNewCol)).Value
 
  For lngCnt = 1 To UBound(arr, 1)
    If arr(lngCnt, lngNewCol) = 65535 Then
      lngStart = lngCnt - 2
    ElseIf arr(lngCnt, lngNewCol) = 52377 Then
      lngEnd = lngCnt
      ReDim var(lngEnd - lngStart + 2, 8)
      lngWrite = 0
      For lngLoop = lngStart To lngEnd
        lngWrite = lngWrite + 1
        For lngVar = 1 To 8
          var(lngWrite, lngVar - 1) = arr(lngLoop, lngVar)
        Next lngVar
      Next lngLoop
      wsTarg.Cells(wsTarg.Rows.Count, 1).End(xlUp).Offset(3).Resize(UBound(var), 8).Value = var
      Erase var
    End If
  Next lngCnt
  .Cells(1, lngNewCol).EntireColumn.Delete
End With
With wsTarg
  .Range("A1").Resize(4).EntireRow.Delete
  .Range("A1:H1").EntireColumn.AutoFit
  Application.Goto .Range("A1"), True
End With

dblEnd = Timer
Application.ScreenUpdating = True

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

End Sub

Function fncCellInteriorColor(rng As Range) As Long
  fncCellInteriorColor = rng.Interior.Color
End Function

I haven't found a way to access the rows of the orignal array at once so another array is used and filled via loop (I know: old, learning nothing new and rusty). On Worksheets("SPEEDTEST") going up to row 10145 timer showed

elapsed time for procedure 'MrE_1226327_1700A0F': 0,75390625 sec

Please make sure that the UDF is copied over as well (in my test both were located in the same module) and that there is only one function of that name present in the workbook.

Holger

Amazing code, I could have never come up with this.

 

[HaHoBe]

Hi kvsrinivasamurthy,

running your code on my sheet SpeedTest brings up

elapsed time for procedure 'DataColoured': 4,015625 sec
elapsed time for procedure 'DataColoured': 3,796875 sec
elapsed time for procedure 'DataColoured': 3,9921875 sec

@shinigamilight:

it took some time for me to figure this one out. I started from a totally different point and am still loking for a way to avoid the loops for passing the data.

Holger