Copy a range of custom colored cells-CodePudding

I need to write a code in order to perform the below action:

From a column, select only the colored cells (eg. in yellow) and copy them under another column already filled with values at the bottom of the list

Here the code i wrote so far however i have troubles writing the part to copy the colored cells to the other sheet:

copycolor Sub m()
Dim wk As Workbook
Dim sh As Worksheet
Dim rng As Range
Dim C As Range
Set wk = ThisWorkbook
With wk
Set sh = .Worksheets("Base Dati Old")
End With
With sh
Set rng = .Range("A:A")
For Each C In rng
If C.Interior.ColorIndex = 46 Then
C.Copy
End If
Next C
End With
End Sub

CodePudding user response：

Assuming you have headers in your data I'd advise to do two things:

Don't loop all cells in column A, it will slow down things significanlty.
If headers are present, applying a filter based on color might be a more optimal way.

For example:

Sub CopyColor()

Dim wk As Workbook: Set wk = ThisWorkbook
Dim sht As Worksheet: Set sht = wk.Worksheets("Base Dati Old")
Dim lr As Long, rng As Range

'Define last used row;
lr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    
'Set range;
Set rng = sht.Range("A1:A" & lr)
    
'Filter your data on yellow;
rng.AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor
    
'Copy filtered cells;
rng.SpecialCells(12).Offset.Copy wk.Worksheets("DestinationSheet").Range("A1")

'Turn off filter
rng.AutoFilter

End Sub

Don't forget to change the name of the sheet you'd want to copy your data to. You may also need to find the last used row for that sheet and make that part dynamic.

Good luck.