copy data based on highlighted cell in column into lastrow from sheet to another

[Abdo]

Hi

I have about 3000 rows some cells in column C contain highlighted cell , what I want macro to search from last row contains highlighted cell until last row doesn't contain color in cell for column C and should delete color in cell when copy to sheet2 .
in sheet2 should clear data from row2 when I run the macro every time to replace data

the data in Sheet1

cell.xlsm
	A	B	C
1	DATE	ACCOUNT REF	BALANCES
2	01/05/2023	PUR PURCHASE INV 0000111	20,000.00
3	02/05/2023	PUR PURCHASE INV 0000112	10,000.00
4	03/05/2023	PUR PURCHASE INV 0000113	1,200.00
5	04/05/2023	PUR PURCHASE INV 0000114	1,300.00
6	05/05/2023	PUR PURCHASE INV 0000115	1,000.00
7	06/05/2023	PUR PURCHASE INV 0000116	1,200.00
8	07/05/2023	PUR PURCHASE INV 0000117	1,200.00
9	08/05/2023	PUR PURCHASE INV 0000118	100.00
10	09/05/2023	PA PAYING 791	300.00
11	10/05/2023	PA PAYING 792	400.00
12	11/05/2023	PA PAYING 793	500.00
13	12/05/2023	PA PAYING 794	340.00
14	13/05/2023	PUR PURCHASE INV 0000119	1,200.00
15	14/05/2023	PUR PURCHASE INV 0000120	1,000.00
16	15/05/2023	PUR PURCHASE INV 0000121	100.00
17	16/05/2023	PUR PURCHASE INV 0000122	1,200.00
18	17/05/2023	PUR PURCHASE INV 0000123	1,200.00
Sheet1

result in sheet2

cell.xlsm
	A	B	C
1	DATE	ACCOUNT REF	BALANCES
2	12/05/2023	PA PAYING 794	340.00
3	13/05/2023	PUR PURCHASE INV 0000119	1,200.00
4	14/05/2023	PUR PURCHASE INV 0000120	1,000.00
5	15/05/2023	PUR PURCHASE INV 0000121	100.00
6	16/05/2023	PUR PURCHASE INV 0000122	1,200.00
7	17/05/2023	PUR PURCHASE INV 0000123	1,200.00
Sheet2

 

[DanteAmor]

The macro considers that you have the standard color yellow and that it is not conditional formatting.
The format on Sheet2 must have the corresponding one, column A the date and column C the amount.

Try this:

Sub Copy_data_based_on_highlighted_cell()
  Dim sh1 As Worksheet
  Dim f As Range
 
  Set sh1 = Sheets("Sheet1")
 
  With Application
    .ScreenUpdating = False
    .FindFormat.Clear
    .FindFormat.Interior.Color = 65535
 
    Sheets("Sheet2").Rows("2:" & Rows.Count).ClearContents
    Set f = sh1.Range("C:C").Find("*", sh1.Range("C" & Rows.Count), xlValues, xlPart, xlByRows, xlPrevious, False, SearchFormat:=True)
    If Not f Is Nothing Then
      sh1.Range(f, sh1.Range("A" & Rows.Count).End(3)).Copy
      Sheets("Sheet2").Range("A2").PasteSpecial xlPasteValues
    End If
 
    .CutCopyMode = False
    .FindFormat.Clear
    .ScreenUpdating = True
  End With
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Abdo]

awesome !
appreciated for this solution .