Boş olan satırları makro ile silmek

[ismail-34]

Değerli Excel Web hocalarıma selamlar saygılar.

benim sorum a sütununda koli numarası bittiğinde ondan sonra gelen renkli satırların dolgularıyla birlikte silnmesi ile ilgili.

örnek ektedir.

 

[antonio]

Merhaba,
Deneyiniz..

Sub Bos_grileri_sil()
Dim ss As Long, i As Long, gri As Long
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For i = 5 To Rows.Count
    If Range("A" & i).Value > 0 Then
        ss = Range("A" & i).Row + 1
    Else
        Exit For
    End If
Next i

gri = Range("A" & ss).Interior.Color

For i = Rows.Count To ss Step -1
    If Range("A" & i).Interior.Color = gri Then
        Range("A" & i).Rows.EntireRow.Delete
    End If
Next i
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
MsgBox "İşlem tamamlandı."

End Sub

 

[Necdet]

Merhaba,
Alternatif olsun.

Sub Makro1()

Dim i   As Long
Dim son As Long

i = 5
son = Cells.SpecialCells(xlCellTypeLastCell).Row
If son < 5 Then Exit Sub

Do Until i = Rows.Count Or Cells(i, 1) = ""
i = i + 1
Loop

Rows(i & ":" & son).Delete

End Sub

 

[veyselemre]

Sub test()
    Dim lRow
    lRow = Cells(Rows.Count, 1).End(3).Row + 1
    If lRow > 5 Then
        Cells(lRow, 1).Formula = "=1/1"
        Range("A5:A" & lRow).SpecialCells(xlCellTypeFormulas, 23).EntireRow.Delete
    End If
End Sub

 

[ismail-34]

Sub test()
    Dim lRow
    lRow = Cells(Rows.Count, 1).End(3).Row + 1
    If lRow > 5 Then
        Cells(lRow, 1).Formula = "=1/1"
        Range("A5:A" & lRow).SpecialCells(xlCellTypeFormulas, 23).EntireRow.Delete
    End If
End Sub

En kısa kod olarak bunu seçtim Teşekkürler değerli hocam saat gibi çalışıo

 

[ismail-34]

Merhaba,
Alternatif olsun.

Sub Makro1()

Dim i   As Long
Dim son As Long

i = 5
son = Cells.SpecialCells(xlCellTypeLastCell).Row
If son < 5 Then Exit Sub

Do Until i = Rows.Count Or Cells(i, 1) = ""
i = i + 1
Loop

Rows(i & ":" & son).Delete

End Sub

eyw güzel çalışıyor hocam.

 

[ismail-34]

Merhaba,
Deneyiniz..

Sub Bos_grileri_sil()
Dim ss As Long, i As Long, gri As Long
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For i = 5 To Rows.Count
    If Range("A" & i).Value > 0 Then
        ss = Range("A" & i).Row + 1
    Else
        Exit For
    End If
Next i

gri = Range("A" & ss).Interior.Color

For i = Rows.Count To ss Step -1
    If Range("A" & i).Interior.Color = gri Then
        Range("A" & i).Rows.EntireRow.Delete
    End If
Next i
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
MsgBox "İşlem tamamlandı."

End Sub

mesajlı güzel bir kod iyi çalışıyor.teşekkürler.