VBA - удалить строки, каждая ячейка в диапазоне которых содержит черный текст

Question

Мне было поручено проанализировать рабочую книгу, в которой мне нужно выделить данные на основе цвета (красного или черного), в котором текст связан со строками.

Мне по сути нужно разработатьмакрос, который удалит все строки, содержащие данные (текст), которые являются «полностью черными» в диапазоне (столбец CJ), и оставит все строки, которые содержат хотя бы одну ячейку в диапазоне (столбец CJ), который содержит текст «red '(255,0,0).

Завершенный результат должен заключаться в том, что каждая строка будет содержать хотя бы одну ячейку, содержащую красный текст между столбцами CJ.

Данные задаются какследующим образом:

Имена:

A1, B1

A2, B2 вплоть до

A2000, B2000

Data (текст) настраивается следующим образом:

C1 до J1

C2 до J2 вплоть до

C2000, J2000

Я нашелмногочисленные коды, которые условно цветовой формат, но я не могу разработать тот, который делает то, что я хочу выше.

Любая помощь будетс благодарностью.

Answer 1

Вы можете использовать автофильтр для фильтрации по цвету шрифта. Не имеет значения, был ли цвет получен путем ручного или условного форматирования.

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

Sub anyRedFont()

    Dim c As Long

    With Worksheets("sheet1")

        'remove any AutoFilters
        If .AutoFilterMode Then .AutoFilterMode = False

        'insert a 'helper' column and label it
        .Columns("C").Insert
        .Cells(1, "C") = "helper"

        'filter for red font color
        With .Range(Cells(1, "C"), .Cells(.Rows.Count, "K").End(xlUp))

            'cycle through columns looking for red font
            For c = 2 To 9

                'fliter for red font
                .AutoFilter Field:=c, Criteria1:=vbRed, _
                            Operator:=xlFilterFontColor, VisibleDropDown:=False

                'put a value into the 'helper' column
                On Error Resume Next
                With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
                    Debug.Print .SpecialCells(xlCellTypeVisible).Address(0, 0)
                    .SpecialCells(xlCellTypeVisible) = 1
                End With
                On Error GoTo 0

                'remove fliter for red font
                .AutoFilter Field:=c

            Next c

            'fliter for non-blank helper column
            .AutoFilter Field:=1, Criteria1:=1, VisibleDropDown:=False

        End With

        'Do your work with the rows containing at least one cell
        'with red font here

        'remove 'helper' column
        'this removes the AutoFilter since the 'helper' column
        'is the primary filter column at this point
        '.Columns(Application.Match("helper", .Rows(1), 0)).Delete

        'remove AutoFilter (manually with Data, Data Tools, Clear)
        'If .AutoFilterMode Then .AutoFilterMode = False

    End With

End Sub

Я прокомментировал удаление столбца 'helper'. «Помощник» - это основной столбец фильтра, поэтому удаление его также приводит к удалению автофильтра.

Answer 2

Я могу также предложить другое мнение, просто для удовольствия. : -)

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

Public Sub RemoveAllRowsWithBlackText()
    Dim rngCells As Range, bFoundNonBlack As Boolean, lngRow As Long
    Dim lngCol As Long

    Set rngCells = Selection

    Application.ScreenUpdating = False

    With rngCells
        For lngRow = .Rows.Count To 1 Step -1
            bFoundNonBlack = False

            For lngCol = 1 To .Columns.Count
                If .Cells(lngRow, lngCol).Font.Color <> 0 And Trim(.Cells(lngRow, lngCol)) <> "" Then
                    bFoundNonBlack = True
                    Exit For
                End If
            Next

            If Not bFoundNonBlack Then
                .Cells(lngRow, lngCol).EntireRow.Delete xlShiftUp
            End If
        Next
    End With

    Application.ScreenUpdating = True
End Sub

... он не привязан к вашим столбцам, он будет перемещаться с выбранным вами выбором.

Answer 3

Вы можете попробовать:

Option Explicit

Sub test()

    Dim i As Long

    With ThisWorkbook.Worksheets("Sheet1")

        For i = 2000 To 2 Step -1

            If .Range("C" & i).Value = "" And .Range("D" & i).Value = "" And .Range("E" & i).Value = "" And .Range("F" & i).Value = "" _
                And .Range("G" & i).Value = "" And .Range("H" & i).Value = "" And .Range("I" & i).Value = "" And .Range("J" & i).Value = "" Then

                .Rows(i).Delete

            End If

        Next i

    End With

End Sub