How can I select the only filled/colored cell in a column?

Question

I am currently working with a workbook that utilizes a row of cells that are colored/filled grey to separate between two sets of data. There isn't any real structure to the way the worksheet it set up, but if I can extract the data to a new sheet then I can format it with some other code I have. The first step for extracting the data would be for me to get to the second data set, which I can do if I can select the row of colored/filled cells. I attempted to use the record function and have come up with the following code:

Application.FindFormat.Clear
    Columns("A:A").Select
    With Application.FindFormat.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.14996795556505
        .PatternTintAndShade = 0
    End With
    Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=True).Activate
ActiveCell.Select
End Sub

The problem is that the above code activates/selects a blank cell with no fill. If anyone could provide me with some insight as to why that might be the case, I would really appreciate that.

Alternatively, if anyone has an idea as to how I can search a specific column for the only filled/colored cell and then return/select that cell address, that would be equally helpful.

Thanks in advance for any advice!

Answer 1

I tend to do things using my own approach rather than the in built way, I find it's then easier for me to debug. That's not true in all cases but with this approach, it is.

Throw this function into a new module in VBA ...

Public Function GetColoredCells(ByVal rngCells As Range) As Range
    Dim objCell As Range, strCells As String

    For Each objCell In rngCells.Cells
        If objCell.Interior.ColorIndex <> xlColorIndexNone Then
            strCells = strCells & "," & Replace(objCell.Address, "$", "")
        End If
    Next

    strCells = Trim(Mid(strCells, 2))

    Set GetColoredCells = rngCells.Range(strCells)
End Function

Public Sub YourRoutineToCopyAndPaste()
    Dim rngCells As Range

    Set rngCells = GetColoredCells(Sheet1.Range("A1:G13"))

    ' From here, you can work with the individual cells that the
    ' GetColoredCells function returned.

    rngCells.Select
End Sub

It doesn't necessarily give you the exact outcome to what you require but you can do something with the logic and it demonstrates the approach. I trust you can take it to the next step.

Answer 2

This is how I'd do it, just adjust rng and then add code for MsgBox

Public Sub FindFilled()

Dim rng As Range
Dim rcell As Range
Set rng = Range("A1:A255")

  For Each rcell In rng.Cells
        If rcell.Interior.ColorIndex <> xlColorIndexNone Then
                MsgBox "Shading in Cell" & rcell.Address ' Do Code Here
                rcell.select
        End If
  Next rcell
End Sub