I'd like to know if it is possible, using VBA, to move a range of cells to the bottom of a column based on the colour of a cell. Here is an example of what I need. The right image is the final result, I don't need to duplicate it. 

![enter image description here](https://i.stack.imgur.com/RDy5M.png)

Here is what I did. 

```
Sub Move_Down()

    Dim lr As Long, lr2 As Long, r As Long, count As Long

    lr = Sheets("Test").Cells(Rows.count, "A").End(xlUp).Row

    Set ws = Sheets("Test")
    count = 1

    'copy the cells with a color
    For r = 2 To lr
        If Sheets("Test").Cells(r, 1).Interior.ColorIndex = 36 Then
            Sheets("Test").Cells(count, 6).Value = Sheets("Test").Cells(r, 1).Value
            Sheets("Test").Cells(count, 7).Value = Sheets("Test").Cells(r, 2).Value
            Sheets("Test").Cells(count, 8).Value = Sheets("Test").Cells(r, 3).Value
            count = count + 1
        End If
    Next r

    'delete cells with color
    For r = 2 To lr
        If Sheets("Test").Cells(r, 1).Interior.ColorIndex = 36 Then
            Sheets("Test").Cells(r, 1) = Empty
            Sheets("Test").Cells(r, 2) = Empty
            Sheets("Test").Cells(r, 3) = Empty
        End If
    Next r

    'paste colored cells at bottom
    lr2 = Sheets("Test").Cells(Rows.count, "F").End(xlUp).Row

    For r = 1 To lr2
        Sheets("Test").Cells(lr + r, 1) = Sheets("Test").Cells(r, 6)
        Sheets("Test").Cells(lr + r, 2) = Sheets("Test").Cells(r, 7)
        Sheets("Test").Cells(lr + r, 3) = Sheets("Test").Cells(r, 8)
        Sheets("Test").Cells(lr + r, 1).Interior.ColorIndex = 36
        Sheets("Test").Cells(r, 6) = Empty
        Sheets("Test").Cells(r, 7) = Empty
        Sheets("Test").Cells(r, 8) = Empty
    Next r

    'delete empty rows

    lastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row

    Set rng = ws.Range("A1:A" & lastRow)
    With rng
        .AutoFilter Field:=1, Criteria1:=Empty
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With

    ws.AutoFilterMode = False

End Sub

```

It does what I need, but I wondered if there was an easier way to do it. 

I need it to not delete the empty rows, because I have other data in those rows.