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.

[GTO]

I am glad that helped. Happy coding!