Visual Basic para Aplicaciones - Ordenar y Eliminar filas sin color

Option Explicit

Sub test()

Dim rng As Range, cell As Range, rng2 As Range

Dim i%

On Error Resume Next

With Application

     .DisplayAlerts = False

     .ScreenUpdating = False

     .EnableEvents = False

     .Calculation = xlCalculationManual

End With

Set rng = Range("A1").CurrentRegion.Resize(, 1)

Set rng2 = rng

Set rng = rng.SpecialCells(xlCellTypeConstants)

For Each cell In rng

    For i = 4 To 8

        cell.Offset(0, i).Value = cell.Offset(1, i).Value

    Next

Next

Set rng2 = getrng(rng, rng2)

rng2.EntireRow.Delete

Range("A1").Select

With Application

     .DisplayAlerts = True

     .ScreenUpdating = True

     .EnableEvents = True

     .Calculation = xlCalculationAutomatic

End With

End Sub

Function getrng(ByVal r1 As Range, ByVal r2 As Range) As Range

Dim ret$

On Error Resume Next

ret = ActiveSheet.Name

Worksheets.Add.Name = "_tmp_"

Range(r1.Address).Value = 1

Range(r2.Address).Value = 1

Intersect(Range(r1.Address), Range(r2.Address)).Clear

Sheets(ret).Select (False)

Cells.SpecialCells(xlCellTypeConstants).Select

Worksheets("_tmp_").Delete

Set getrng = Selection

End Function

Option Explicit

Sub test()

Dim rng As Range, cell As Range, rng2 As Range

Dim i&, y&, c&

On Error Resume Next

With Application

     .DisplayAlerts = False

     .ScreenUpdating = False

     .EnableEvents = False

     .Calculation = xlCalculationManual

End With

Set rng = Range("A1").CurrentRegion.Resize(, 1)

Set rng2 = rng

Set rng = rng.SpecialCells(xlCellTypeConstants)

For Each cell In rng

    y = 1

    c = 4

    Do While 1

       With cell

            If .Offset(y, 0).Interior.ColorIndex <> xlColorIndexNone Or VBA.Trim(.Offset(y, 4).Value) = "" Then Exit Do

            For i = 4 To 8

                .Offset(0, c).Value = .Offset(y, i).Value

                c = c + 1

            Next

            y = y + 1

       End With

    Loop

Next

Set rng2 = getrng(rng, rng2)

rng2.EntireRow.Delete

Range("A1").Select

With Application

     .DisplayAlerts = True

     .ScreenUpdating = True

     .EnableEvents = True

     .Calculation = xlCalculationAutomatic

End With

End Sub

Function getrng(ByVal r1 As Range, ByVal r2 As Range) As Range

Dim ret$

On Error Resume Next

ret = ActiveSheet.Name

Worksheets.Add.Name = "_tmp_"

Range(r1.Address).Value = 1

Range(r2.Address).Value = 1

Intersect(Range(r1.Address), Range(r2.Address)).Clear

Sheets(ret).Select (False)

Cells.SpecialCells(xlCellTypeConstants).Select

Worksheets("_tmp_").Delete

Set getrng = Selection

End Function

Option Explicit

Sub test()

Dim rng As Range, cell As Range

Dim i&, y&, c&

Dim col As New Collection

On Error Resume Next

With Application

     .DisplayAlerts = False

     .ScreenUpdating = False

     .EnableEvents = False

     .Calculation = xlCalculationManual

End With

Set rng = Range("A1").CurrentRegion.Resize(, 1)

Set rng = rng.SpecialCells(xlCellTypeConstants)

For Each cell In rng

    y = 1

    c = 4

    Do While 1

       With cell

            If .Offset(y, 0).Interior.ColorIndex <> xlColorIndexNone Or VBA.Trim(.Offset(y, 4).Value) = "" Then Exit Do

            col.Add .Offset(y, 0).Address(0, 0)

            For i = 4 To 8

                .Offset(0, c).Value = .Offset(y, i).Value

                c = c + 1

            Next

            y = y + 1

       End With

    Loop

Next

c = col.Count

For i = c To 1 Step -1

    Range(col.Item(i)).EntireRow.Delete

Next

Range("A1").Select

With Application

     .DisplayAlerts = True

     .ScreenUpdating = True

     .EnableEvents = True

     .Calculation = xlCalculationAutomatic

End With

End Sub