удалить все ячейки определенного цвета - PullRequest
Новая
       18

удалить все ячейки определенного цвета

0 голосов
/ 14 сентября 2018

Это кажется относительно простым и, как я понимаю, это возможно. Но я не могу понять это или найти то, что я ищу в Интернете.

У меня есть некоторые данные Excel в столбце A, и некоторые из них синие (0,0,255), некоторые красные (255,255,255), некоторые зеленые (0, 140, 0). Я хочу удалить все синие данные.

Мне сказали, что: 

Sub test2()
    Range("A2").DisplayFormat.Font.Color
End Sub

Дало бы мне цвета ... но когда я запускаю, он говорит о недопустимом использовании свойства и выделяет .color

Вместо этого я нажал на: Цвет шрифта выпадающий тогда больше цветов тогда пользовательские цвета тогда я вижу, что данные синим цветом находятся в (0,0,255)

Итак, я попробовал: 

Sub test()

Dim wbk As Workbook
Dim ws As Worksheet
Dim i As Integer
Set wbk = ThisWorkbook
Set ws = wbk.Sheets(1)

Dim cell As Range

With ws
    For Each cell In ws.Range("A:A").Cells
        'cell.Value = "'" & cell.Value
        For i = 1 To Len(cell)
            If cell.Characters(i, 1).Font.Color = RGB(0, 0, 255) Then
                If Len(cell) > 0 Then
                    cell.Characters(i, 1).Delete
                End If
                If Len(cell) > 0 Then
                    i = i - 1
                End If
            End If
        Next i
    Next cell
End With

End Sub

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

Ответы [ 4 ]

0 голосов
/ 14 сентября 2018 
Option Explicit
Sub test2()

Dim cel As Range
Dim LR As Long

LR = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

For Each cel In ActiveSheet.Range("A1:A" & LR)

    If cel.Font.Color = RGB(0, 0, 255) Then cel.ClearContents
Next cel
End Sub
0 голосов
/ 14 сентября 2018

Вы можете использовать Range объект Autofilter() метод с оператором xlFilterFontColor; 

Sub test()       
    With ThisWorkbook.Sheets(1)
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            .AutoFilter Field:=1, Criteria1:=RGB(0, 0, 255), Operator:=xlFilterFontColor
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 0 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
        End With
        .AutoFilterMode = False
        If .Range("A1").Font.Color = RGB(0, 0, 255) Then .Range("A1").ClearContents ' check first row, too (which is excluded by AutoFilter)
    End With
End Sub
0 голосов
/ 14 сентября 2018

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

For Each cel In ActiveSheet.Range("A1:A30")
    If cel.Font.Color = RGB(0, 0, 255) Then cel.Delete
Next cel

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

Dim rng As Range
Set rng = Application.InputBox("Select a Cell:", "Obtain Range Object", Type:=8)

    With ActiveSheet
        Dim lr As Long
        lr = Cells(Rows.Count, 1).End(xlUp).Row

        Dim x As Long
        x = rng.Row

        For i = lr To x Step -1
            If .Cells(i, 1).Font.Color = rng.Font.Color Then .Cells(i, 1).Clear
        Next i
    End With
0 голосов
/ 14 сентября 2018

Что-то вроде следующего, где все подходящие ячейки собраны вместе, используя Union, и удалены за один раз. Если вы удаляете целые строки по отдельности, вам всегда нужно вернуться назад. Удаление / очистка за один раз более эффективна. 

Sub test()
    Dim wbk As Workbook, ws As Worksheet
    Dim i As Long, currentCell As Range, unionRng As Range

    Set wbk = ThisWorkbook
    Set ws = wbk.Worksheets("Sheet1")

    With ws
        For Each currentCell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)  '<==assuming actual data present
            If  currentCell.Font.Color = RGB(0, 0, 255) Then
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(currentCell, unionRng)
                Else
                    Set unionRng = currentCell
                End If
            End If
        Next
    End With
    If Not unionRng Is Nothing Then unionRng.Delete
End Sub

image

...