vba to copy a content of cells marked green

[megtoma]

Hello,
Could anyone please help me to create a vba code which copies cells marked as green located within a range CV26:CV670 in Sheet1 into Sheet2?

Many thanks in advance.

[GTO]

Marked as green how? Through actually changing the cells' interior color, or Data Validation?

In either case, what color of green?

Presuming the cells' interior color is changed, select a green cell and run:

Sub WhatColorAreI()
MsgBox ActiveCell.Interior.Color
End Sub


...What is the result?

Mark

[megtoma]

Hi,
The colour is 65280 and those are cells I filled in with that colour.

[GTO]

Thank you for the clear response :-)

In a Standard Module, try:



Option Explicit

Public Sub CopyColoredCellsValues()
Dim rngFirstEmptyCell As Range
Dim CellInSearchRange As Range
Dim lRowToPutNextValueIn As Long

'// Attempt to set a reference to the last cell with any data in our destination range. //
Set rngFirstEmptyCell = RangeFound(Sheet2.Range(Sheet2.Range("A2"), Sheet2.Cells(Sheet2.Rows.Count, "A")))

'// If no cell has any data yet, start filling at row 2 (presumes a header), else... //
If rngFirstEmptyCell Is Nothing Then
lRowToPutNextValueIn = 2
Else
'// ... offset by 1 for the first empty row/cell. //
lRowToPutNextValueIn = rngFirstEmptyCell.Row + 1
End If

For Each CellInSearchRange In Sheet1.Range("CV26:CV670").Cells
If CellInSearchRange.Interior.Color = 65280 Then
'// When we find a cell of the proper color, take the value and adjust our index. //
Sheet2.Cells(lRowToPutNextValueIn, "A").Value = CellInSearchRange.Value
lRowToPutNextValueIn = lRowToPutNextValueIn + 1
End If
Next

End Sub

Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange.Cells(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

I failed to mention it in the comments, but please note that I used the sheets' default CodeName(s).

Hope that helps,

Mark

[megtoma]

Brilliant. It works!
Many many thanks. :clap2:

[GTO]

I am glad that helped. Happy coding!