Удалить строки на основе цвета ячеек

Question

На данный момент у меня есть несколько ячеек, которые выглядят примерно так:

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

В настоящий момент у меня есть такой код

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

Что Я надеюсь, что этот код делает то, что он распознает, если значение активной ячейки равно ячейке сверху, а затем, если их значения равны I l oop, через ячейки от столбца H до столбца S и копирует ячейки зеленые и вставьте их сверху

Проблема, с которой я столкнулся на данный момент, заключается в том, что когда мой код находит две ячейки с одинаковыми именами после перехода в строку

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

Компилятор просто пропускает оставшуюся часть кода и больше ничего не выполняет, может кто-нибудь помочь мне понять, почему пропускается остальная часть моего кода?

Answer 1

Я не уверен на 100% в коде, потому что он сложный, но я пытаюсь что-то создать:

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