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

 

[shinigamilight]

Sub dream()
        Dim lr As Long
        Dim Coloring As Long
        Dim wk1, wk2 As Worksheet
        Set wk1 = Sheets("Project1") 'this is the input sheet
        Set wk2 = Sheets("Project2") ' this is the output sheet aka result sheet
        Dim k As Integer
       
        ' make sure input sheet is selected at the time of running the code very important
       
        lr = Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious, False).Row
        Coloring = 52377 'this is the color of your highlighted cell you can change it to your liking
       
        For k = 1 To lr
                If wk1.Range("H" & k).Interior.Color = Coloring Then
                    wk1.Range("H" & k).CurrentRegion.Copy _
                        wk2.Range("A" & Rows.Count).End(xlUp).Offset(4, 0)
                End If
        Next k
       
        wk2.Range("A1:A4").EntireRow.Delete shift:=xlUp
       
       

       
End Sub

 

[shinigamilight]

Sub dream2()
        ' this how your find the color of a cell
        
        MsgBox Range("H9").Interior.Color
        
End Sub

 

[KalilMe]

thanks but seem slow when I have data 8000 rows . it takes more time .
do you have a way to make faster ,please?

 

[HaHoBe]

Hi KalilMe,

what about

Public Sub MrE_1226327_1700811()
' 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

'/// Please note: ALWAYS run the macros on a copy of your Workbook !!!!

Dim wsTarg As Worksheet
Dim wsData As Worksheet
Dim lngStart 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

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.ColorIndex = 6 Then
        Set rngHit = wsTarg.Columns(5).Find(.Cells(2, "E").Value, LookIn:=xlValues)
        If Not rngHit Is Nothing Then
          Set rngTarg = rngHit.CurrentRegion
          rngTarg.Cells(rngTarg.Rows.Count, "H").Value = .Range("H" & .Rows.Count).Value
          Set rngTarg = Nothing
          Set rngHit = Nothing
        End If
      End If
      lngStart = .Cells(.Rows.Count, .Columns.Count).End(xlDown).Row
    End With
    Set rngWork = Nothing
  Loop
End With

Application.ScreenUpdating = False
Set wsTarg = Nothing
Set wsData = Nothing
End Sub

Ciao,
Holger

 

[KalilMe]

@HaHoBe
thanks but I no know what's the problem !
there is no error and doesn't show anything in result sheet

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, rng As Range, srcRng As Range
    With Sheets("RETSEL")
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1:H" & LastRow).AutoFilter Field:=8, Criteria1:=RGB(153, 204, 0), Operator:=xlFilterCellColor
        Set srcRng = .Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible)
        .Range("A1").AutoFilter
        For Each rng In srcRng
            .Range("H" & rng.Row).CurrentRegion.Copy Sheets("result").Cells(Sheets("result").Rows.Count, "A").End(xlUp).Offset(4)
        Next rng
    End With
    Sheets("result").Range("A1").Resize(4).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

 

[HaHoBe]

Hi KalilMe,

Public Sub MrE_1226327_1700811_mod()
' 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

'/// Please note: ALWAYS run the macros on a copy of your Workbook !!!!

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")

wsTarg.Cells.Clear

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.ColorIndex = 6 Then
        wsTarg.Cells(lngCopy, 1).Resize(.Rows.Count, .Columns.Count).Value = .Value
        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

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

Holger

 

[KalilMe]

@mumps thanks
sorry I said that ! the code is really slow.

 

[KalilMe]

@HaHoBe
again there is no error and doesn't show anything in result sheet !