根据单元格颜色删除行

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?

Answer 1

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