Delete rows based on colour of cells

Question

At the moment I have some cells that look something like this

What I want to achieve is something that deletes duplicates but also puts all of the green cells into the same row

What I have at the moment is a code like this

Sub Delete_Duplicates()

Worksheets("MySheet").Activate

'Obtain the last row with data on column 2 
a = Worksheets("MySheet").Cells(Rows.Count, 2).End(xlUp).Row

'Loop through the name of the items 
For b = a To 6 Step -1

CurrentCell = Cells(b, 2).Select
CellValue = Cells(b, 2).Value
CellUp = ActiveCell.Offset(-1, 0)

If ActiveCell.Value = CellUp Then

For c = 8 To 19

If Range(b, c).Interior.Color = RGB(146, 208, 80) Then

Worksheets("MySheet").Range(b, c).Activate

Range(b, c).Copy Destination:=ActiveCell.Offset(-1, 0)

Rows(a).EntireRow.Delete

End If

Next c

End If

Next b

End Sub

What I am hoping that this code does is that it recognises if the value of the active cell is equal to the cell on top and then if their values are equal I loop through the cells from column H to column S and copy the cells that are green and paste them on top

The issue that I have at the moment is that when my code finds two cells with equal names after going to the line

If Range(b, c).Interior.Color = RGB(129, 188, 0) Then

The compiler just skips the rest of the code and wont execute anything else, can anyone help me see why is the rest of my code being skipped?

You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). — Pᴇʜ, Mar 12 '20 at 10:51

score 0 · Answer 1 · answered Mar 12 '20 at 13:37

I m not 100% sure about the code because was to complex but i try to create something:

Sub TEST()

    Dim LastRow As Long, i As Long, y As Long, w As Long, k As Long, RowCounter As Long, FirstInstant As Long, o As Long, l As Long
    Dim arrNames As Variant, arrNumber(0) As Variant, arrCheck As Variant, arrDelete(0) As Variant, arrColor As Variant, arrSplit As Variant
    Dim Found As Boolean, Found_2 As Boolean

    RowCounter = 0
    FirstInstant = 0

    With ThisWorkbook.Worksheets("Sheet2")

         LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

         arrNames = .Range("B6:B" & LastRow)

         'Loop name
         For i = LBound(arrNames) To UBound(arrNames)

            'Loop rows
            For y = 6 To LastRow

                'Check there is a match
                If arrNames(i, 1) = .Range("B" & y).Value Then

                    If FirstInstant = 0 Then
                        FirstInstant = y
                    End If

                    If RowCounter > 0 Then

                        If arrDelete(0) = "" Then
                            arrDelete(0) = y & ":" & y
                        Else
                            arrSplit = Split(arrDelete(0), ",")

                            For l = LBound(arrSplit) To UBound(arrSplit)

                                If arrSplit(l) = y & ":" & y Then

                                    Found_2 = True
                                    Exit For

                                End If

                            Next l

                            If Found_2 = False Then
                                arrDelete(0) = arrDelete(0) & "," & y & ":" & y
                            End If

                        End If
                    Else
                        RowCounter = RowCounter + 1
                    End If

                    'Loop columns
                    For w = 3 To 19

                        'Check if there is color
                        If .Cells(y, w).Interior.Color = RGB(129, 188, 0) Then

                            If arrNumber(0) = "" Then
                                arrNumber(0) = w
                            Else

                                arrCheck = Split(arrNumber(0), ",")
                                Found = False

                                'Check if the column already excist
                                For k = LBound(arrCheck) To UBound(arrCheck)

                                    If arrCheck(k) = w Then

                                        Found = True
                                        Exit For

                                    End If

                                Next k

                                If Found = False Then
                                    arrNumber(0) = arrNumber(0) & "," & w
                                End If

                            End If

                        End If

                    Next w

                End If

            Next y

            'Color
            If arrNumber(0) <> "" Then

                arrColor = Split(arrNumber(0), ",")

                For o = LBound(arrColor) To UBound(arrColor)

                    .Cells(FirstInstant, CLng(arrColor(o))).Interior.Color = RGB(129, 188, 0)

                Next o


            End If

            RowCounter = 0
            FirstInstant = 0

            Erase arrNumber
            Erase arrCheck
            Erase arrColor

         Next i

         .Range(arrDelete(0)).EntireRow.Delete

    End With

End Sub

Delete rows based on colour of cells

1 Answers1