Paste data based on cell color

[hardeep.kanwar]

Hi Experts

We have data (know as Time sheet) where employees are putting there daily time every day and my task to check putting more then 8 Hr (Basically more than 10 Hrs),so i highlight the data by using Find Function and highlights those cells.

Now i am doing manually copy paste the data of each employee (Total 218) one by one.

Is there any way to paste only data data to another sheet.

Name	1-Nov-24	2-Nov-24	3-Nov-24	4-Nov-24
A	8	8	8	8
B	8	8	8	8
C	8	8	8	8
D	8	8	8	8
E	8	8	8	8
F	8	18	12	14
G	8	8	8	8
H	8	8	8	8
I	8	12	11	8
J	8	8	8	8
K	8	8	8	8
L	8	10	13	15
M	8	8	8	8
N	8	8	8	8
O	12	13	14	16
P	8	8	8	8

Name	1-Nov-24	2-Nov-24	3-Nov-24	4-Nov-24
F		18	12	14
I		12	11
L		10	13	15
O	12	13	14	16

 

[hardeep.kanwar]

Sorry to forget the data

 

[Peter_SSs]

Assuming ..

1. Your original data is on Sheet1
2. Results to go on Sheet2
3. Sheet2 already exists
4. Any data already on Sheet2 can be deleted

.. then try this with a copy of your workbook.
Note that this does not use the highlight colour, it just transfers the data if the cell value > 8.

Sub Overtime()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, uba2 As Long
 
  a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a), 1 To uba2)
  For i = 1 To UBound(a)
    For j = 2 To uba2
      If a(i, j) > 8 Then
        b(i, 1) = a(i, 1)
        b(i, j) = a(i, j)
      End If
    Next j
  Next i
  With Sheets("Sheet2")
    .UsedRange.ClearContents
    With .Range("A1").Resize(UBound(a), uba2)
      .Value = b
      On Error Resume Next
      .Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
      On Error GoTo 0
    End With
  End With
End Sub