Sub Перенос()
Dim c As Range
Dim lr1 As Long, lr2 As Long
Dim a()
    lr1 = Cells(Rows.Count, 2).End(xlUp).Row 'находим номер последней строки на листе орк
    With Sheets("Маршрутные листы.") 'с листом "Маршрутные листы."
        lr2 = .Cells(Rows.Count, 4).End(xlUp).Row + 1 'находим номер последней строки на листе "Маршрутные листы." + 1
        .Cells(lr2, 5) = Date 'ставим дату разделитель
        lr2 = lr2 + 1 'увеличиваем номер строки
        For Each c In Range("B2:B" & lr1) 'для всех ячеек в диапазоне ...
            If c.Interior.ColorIndex = RGB(191, 191, 191) Then 'если заливка серый то
                a = Range("B" & c.Row & ":H" & c.Row) 'вносим в массив диапазон
                .Cells(lr2, 1).Resize(1, 7) = a 'копируем строку на лист "Маршрутный лист."
                .Cells(lr2, 8) = Date 'ставим дату в последнюю колонку
                lr2 = lr2 + 1 'увеличиваем номер строки
            End If
        Next
    End With
    For i = lr To 3 Step -1 'от последней строки до 3й с шагом -1
        If Cells(i, 2).Interior.ColorIndex = RGB(191, 191, 191) Then 'если заливка серый то
            Rows(i).Delete 'строку удаляем
        End If
    Next
    'Call Сортировка
End Sub