VBA macro to delete highlighted cells

[Yamasaki450]

Hello i need some help again.

I need macro to delete all red highlighted cells. My data goes from BE 1646 to MPT 3252. Cells are highlighted with conditional formatting if this matters...(see first screenshot)

And then i need to remove all blank cells and sort data in same order as before deleting highlighted cells (see second screenshot for example)

Or maybe there is another faster way to do this?

Thanks.

 

[Cubist]

Try on a copy.

Sub DeleteRedCellsAndShiftUp2()
    Dim rng As Range
    Dim cell As Range
    Dim redCells As Range
    Dim redCount As Long
 
    Set rng = Range("BE1646:MPT3252")
    For Each cell In rng
        If cell.DisplayFormat.Interior.Color = RGB(255, 0, 0) Then
            If redCells Is Nothing Then
                Set redCells = cell
            Else
                Set redCells = Union(redCells, cell)
            End If

        End If
    Next cell
 
    If Not redCells Is Nothing Then
        redCells.ClearContents
    End If

    rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End Sub

 

[Yamasaki450]

Try on a copy.

Sub DeleteRedCellsAndShiftUp2()
    Dim rng As Range
    Dim cell As Range
    Dim redCells As Range
    Dim redCount As Long
 
    Set rng = Range("BE1646:MPT3252")
    For Each cell In rng
        If cell.DisplayFormat.Interior.Color = RGB(255, 0, 0) Then
            If redCells Is Nothing Then
                Set redCells = cell
            Else
                Set redCells = Union(redCells, cell)
            End If

        End If
    Next cell
 
    If Not redCells Is Nothing Then
        redCells.ClearContents
    End If

    rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End Sub

Thanks. This works but it takes very very long time to process even if i limit range to just 20 columns... Anyone have any other idea how to do this faster?

 

[Cubist]

Maybe this

Sub DeleteRedCellsAndShiftUp3()
    Dim rng As Range
    Dim cell As Range
    Dim redCells As Range
    Dim redCount As Long
    Dim dataArray As Variant
    Dim i As Long, j As Long

    Set rng = Range("BE1646:MPT3252")

    dataArray = rng.Value
    For i = 1 To UBound(dataArray, 1)
        For j = 1 To UBound(dataArray, 2)
            If dataArray(i, j) <> "" Then 
                If rng.Cells(i, j).DisplayFormat.Interior.Color = RGB(255, 0, 0) Then
                    If redCells Is Nothing Then
                        Set redCells = rng.Cells(i, j)
                    Else
                        Set redCells = Union(redCells, rng.Cells(i, j))
                    End If
                End If
            End If
        Next j
    Next i

    If Not redCells Is Nothing Then
        redCells.ClearContents
    End If

    rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End Sub

 

[kevin9999]

This took just under 1 second for 20 columns, although it took 6.5 minutes for your full 14M+ cells - I'm working on making that faster. Please try on a copy of your workbook.

Option Explicit
Sub Delete_Red_Cells()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- *** Change sheet name to suit ***
    Dim r As Range
    Set r = ws.Range("BE1646").CurrentRegion
    
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long
    LRow = r.Rows.Count
    LCol = r.Columns.Count
    k = 1
    For j = 1 To LCol
        For i = 1 To LRow
            If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 0, 0) Then
                b(k, j) = a(i, j)
                k = k + 1
            End If
        Next i
        k = 1
    Next j
    ws.Range("BE1646").Resize(LRow, LCol).Value = b
    MsgBox Timer - t
End Sub

 

[Yamasaki450]

Maybe this

Sub DeleteRedCellsAndShiftUp3()
    Dim rng As Range
    Dim cell As Range
    Dim redCells As Range
    Dim redCount As Long
    Dim dataArray As Variant
    Dim i As Long, j As Long

    Set rng = Range("BE1646:MPT3252")

    dataArray = rng.Value
    For i = 1 To UBound(dataArray, 1)
        For j = 1 To UBound(dataArray, 2)
            If dataArray(i, j) <> "" Then
                If rng.Cells(i, j).DisplayFormat.Interior.Color = RGB(255, 0, 0) Then
                    If redCells Is Nothing Then
                        Set redCells = rng.Cells(i, j)
                    Else
                        Set redCells = Union(redCells, rng.Cells(i, j))
                    End If
                End If
            End If
        Next j
    Next i

    If Not redCells Is Nothing Then
        redCells.ClearContents
    End If

    rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End Sub

This is faster then previous one at deleting cells but still slow at sorting...

This took just under 1 second for 20 columns, although it took 6.5 minutes for your full 14M+ cells - I'm working on making that faster. Please try on a copy of your workbook.

Option Explicit
Sub Delete_Red_Cells()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- *** Change sheet name to suit ***
    Dim r As Range
    Set r = ws.Range("BE1646").CurrentRegion
   
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long
    LRow = r.Rows.Count
    LCol = r.Columns.Count
    k = 1
    For j = 1 To LCol
        For i = 1 To LRow
            If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 0, 0) Then
                b(k, j) = a(i, j)
                k = k + 1
            End If
        Next i
        k = 1
    Next j
    ws.Range("BE1646").Resize(LRow, LCol).Value = b
    MsgBox Timer - t
End Sub

This one is lighting fast! Im happy with this. Waiting couple of minutes for so much data its no problem. Thank you very much.

One more question... What i need to do if i want to delete white cells(non highlighted) so just opposite. Im guessing i just need to change RGB(255, 0, 0)? To what? Can you post example please.

 

[kevin9999]

Happy to help & thanks for the feedback

'White' cells should be RGB(255,255,255) therefore:

If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 255, 255) Then

 

[kevin9999]

Or if there's no interior color set, you could try:

If r.Cells(i, j).DisplayFormat.Interior.ColorIndex = 0 Then

 

[Yamasaki450]

This took just under 1 second for 20 columns, although it took 6.5 minutes for your full 14M+ cells - I'm working on making that faster. Please try on a copy of your workbook.

Option Explicit
Sub Delete_Red_Cells()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- *** Change sheet name to suit ***
    Dim r As Range
    Set r = ws.Range("BE1646").CurrentRegion
   
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long
    LRow = r.Rows.Count
    LCol = r.Columns.Count
    k = 1
    For j = 1 To LCol
        For i = 1 To LRow
            If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 0, 0) Then
                b(k, j) = a(i, j)
                k = k + 1
            End If
        Next i
        k = 1
    Next j
    ws.Range("BE1646").Resize(LRow, LCol).Value = b
    MsgBox Timer - t
End Sub

I ended up using this VBA quite often and for 14M cells still takes quite a while to process...
Can you look in to this and make it even faster if possible?

My sheets are packed with conditional formatting formulas similar to this "(=AND($BC2=3;BE2>=-4;BE2<=65)" if this matters... This probably affects the speed too...

Thanks.

 

[kevin9999]

14M plus cells is still 14M plus cells so expect some time lag
Conditional formatting will definitely slow things down - is it necessary; are there other ways (VBA) of achieving the same formatting after all other processing has occurred; or is it the CF that gives the cells their red colour? In which case, is there another way we can use the values in the cells (rather than the colour) to perform the delete?