Как выбрать единственную заполненную / цветную ячейку в столбце?

Question

В настоящее время я работаю с книгой, в которой используется ряд ячеек, которые окрашены / заполнены серым цветом для разделения между двумя наборами данных.Нет никакой реальной структуры в том, как настроен рабочий лист, но если я смогу извлечь данные на новый лист, то смогу отформатировать его с помощью другого имеющегося у меня кода.Первым шагом для извлечения данных было бы для меня перейти ко второму набору данных, что я могу сделать, если смогу выбрать ряд цветных / заполненных ячеек.Я попытался использовать функцию записи и придумал следующий код:

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

Проблема в том, что приведенный выше код активирует / выбирает пустую ячейку без заполнения.Если бы кто-нибудь мог дать мне некоторое представление о том, почему это может иметь место, я был бы очень признателен.

В качестве альтернативы, если у кого-то есть идея, как я могу найти в определенном столбце только заполненную / окрашенную ячейку, а затем вернуть / выбрать этот адрес ячейки, это было бы одинаково полезно.

Заранее спасибо за любые советы!

Answer 1

Вот как я это сделаю, просто настройте rng, а затем добавьте код для 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

Answer 2

Я склонен делать что-то, используя мой собственный подход, а не встроенный, и я обнаружил, что мне легче отлаживать. Это не так во всех случаях, но при таком подходе это так.

Добавьте эту функцию в новый модуль в 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

Это не обязательно даст вам точный результат для того, что вам нужно, но вы можете сделать что-то с логикой, и это демонстрирует подход. Я надеюсь, что вы можете перейти к следующему шагу.