Excel VBA - поиск начала и конца цветных строк

Я пытаюсь создать код в Excel VBA, чтобы найти начало (Cell Address) и конец (Cell Address) цветных строк в таблице. Таблица представляет собой временную шкалу (Горизонтальные axis- Даты, Вертикальная ось - Общий текст). Цветные строки не начинаются в первом столбце, а начинаются с разных столбцов. Любая помощь?

-3
источник поделиться
1 ответ

Как это?

Sub findColoredRows()
Dim startCol As Integer, endCol As Integer, o As Integer
Dim ws            As Worksheet
Dim i As Integer, k As Integer
Dim startRow As Long, endRow As Long
Dim cellColor As String, noColor As String
Dim cel           As Range

noColor = -4142              ' this is the color index of NO coloring

k = 3

Set ws = ActiveSheet
With ws
    startRow = .Cells(1, 3).End(xlDown).Row
    startCol = .Cells(1, 3).Column
    Do While startRow > 100  ' I assume your table starts before row 100.  So, if there no data before row 100, check next column
        k = k + 1
        startRow = .Cells(1, k).End(xlDown).Row
        startCol = k
    Loop

    'Now, we have our starting row - get end row.
    endRow = .Cells(startRow, k).End(xlDown).Row

    endCol = .Cells(startRow, startCol).End(xlToRight).Column
    Debug.Print "Start row: " & startRow & ", start column: " & startCol

    ' How many non colored cells is there in our range?
    Dim noColorCells As Integer
    For Each cel In .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
        If cel.Interior.ColorIndex = noColor Then
            noColorCells = noColorCells + 1
        End If
    Next cel
    Debug.Print "There are " & noColorCells & " non colored cells."

    .Cells(startRow - 1, endCol + 2).Value = "Start Date"
    .Cells(startRow - 1, endCol + 3).Value = "End Date"

    'reDim the array to fit the colored cells
    ReDim tDates(1 To noColorCells + 1)
    i = 1                    'index starts at 1, so set this to 1

    For k = startRow To endRow
        For o = startCol To endCol
            If .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) = "" Then
                .Cells(k, endCol + 2).Value = .Cells(k, o).Value
            ElseIf .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) Then
                i = i + i
                .Cells(k, endCol + 3).Value = .Cells(k, o).Value
            End If
            ' i = i + 1
        Next o

        i = i + 1
    Next k

End With

MsgBox ("Done!")

End Sub

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

Изменение: в приведенном ниже обсуждении попробуйте сделать это, если в таблице не всегда содержатся данные, но вы хотите, чтобы столбцы цветных ячеек:

Sub findColoredBGCells()
Dim startRow As Integer, endRow As Integer, i As Integer, k As Integer, startCol As Integer, endCol As Integer
Dim cellColor As String, noColor As String
Dim ws As Worksheet

Set ws = ActiveSheet
noColor = -4142

With ws
    'Get the starting row
    startRow = .Cells(1, 1).End(xlDown).Row
    endRow = .Cells(startRow, 1).End(xlDown).Row

    ' Since we know where the names start and end (less ONE for the "Names" part), let count how many names we have
    Dim noNames As Integer
    noNames = endRow - startRow
    If Not IsEmpty(.Cells(1, 1)) Then ' Get the first used column with data
        startCol = 1
    ElseIf IsEmpty(.Cells(1, 1)) Then
        startCol = .Cells(1, 1).End(xlToRight).Column
    End If

    endCol = .Cells(1, startCol).End(xlToRight).Column

    'Now we have our range, let use it to loop for blank cells, and add those to an array
    Dim coloredCells() As Variant
    ReDim coloredCells(1 To noNames, 2)
    Dim rng As Range, cel As Range
    Set rng = .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
    'rng.Select

    'Now, count how many cells are not blank background
    Dim cnt As Integer, celRow As Integer, lastCelRow As Integer
    i = 1

    lastCelRow = 2
    For Each cel In rng
        cel.Select
        celRow = cel.Row
        If cel.Row <> lastCelRow Then 'This is so we can change the first dimension in the array
            k = k + 1
            coloredCells(k, 0) = .Cells(cel.Row, 1).Value
            i = 1
           ' i = i + 1
        End If

        If cel.Interior.ColorIndex <> noColor Then
            cnt = cnt + 1
            If i > 2 Then i = 2 'Since it only two dimensions we need, only go up to '1'
           ' ReDim Preserve coloredCells(noNames, i) 'resize the array to hold the new column
            coloredCells(k, i) = .Cells(1, cel.Column).Value
            i = i + 1
        End If
        lastCelRow = celRow
    Next cel

For k = 1 To UBound(coloredCells)
        Debug.Print coloredCells(k, 0) & " Start Date: " & coloredCells(k, 1) & ", end date: " & coloredCells(k, 2) & "."
        .Cells(2 + k, 2).Value = coloredCells(k, 1)
        .Cells(2 + k, 3).Value = coloredCells(k, 2)
Next k

End With

MsgBox ("Done!")

End Sub
0
источник

Посмотрите другие вопросы по меткам или Задайте вопрос