Son satırı bularak silmek

[halilerdem]

Aşağıdaki kodu tablomda çalıştırdığımda , tablomun özelliği şöyle ; H sütununa kadar bütün hücreler dolu H sütununda arada boş olan hücreler var bu H sütununda boş olan hücrelerin satırlarını silmek istiyorum arada kalan bütün satırları siliyor fakat en sonda mesela H50,H51 gibi hücreler boş olduğu halde bu satırları silmiyor nerede yanlışlık var acaba ?

Sub satirsil()

Dim son As Long, deg, i As Long, durum As Boolean, j As Integer

son = Cells(Rows.Count, "H").End(xlUp).Row

deg = Array("", " ", "0")

Application.ScreenUpdating = False

For i = son To 1 Step -1

durum = False

For j = 0 To UBound(deg)

If Cells(i, "H") Like deg(j) Then durum = True

If durum = True Then Exit For

Next j

If durum = True Then Rows(i).Delete Shift:=xlUp
Next i
End Sub

 

[muratboz06]

If durum = True Then Rows(i).Delete Shift:=xlUp satırını
If durum = True Then
Rows(i).Delete Shift:=xlUp
i = i+1
end if
olarak değiştirip deneyiniz.

 

[halilerdem]

Murat Bey olmadı
Dosyası ekledim bakabilir misiniz

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Delete_Rows()
    Dim My_Cell As Range, My_Area As Range
    Dim Find_Value As Variant, My_Checked As Boolean
    
    Find_Value = Array("", " ", 0)
    
    For Each My_Cell In Range("H2:H" & Cells(Rows.Count, 1).End(3).Row)
        On Error Resume Next
        My_Checked = False
        My_Checked = WorksheetFunction.Match(My_Cell.Value, Find_Value, 0)
        On Error GoTo 0
        If My_Checked = True Then
            If My_Area Is Nothing Then
                Set My_Area = My_Cell
            Else
                Set My_Area = Union(My_Area, My_Cell)
            End If
        End If
    Next
    
    If Not My_Area Is Nothing Then
        My_Area.EntireRow.Delete Shift:=xlUp
        MsgBox "Your transaction is complete.", vbInformation
    Else
        MsgBox "No suitable records found!", vbExclamation
    End If
End Sub

 

[dost]

Merhaba,

Sayın Korhan AYHAN'ın kodu gayet hızlı çalışıyor.

Alternatif olması açısından:

Option Explicit

Sub remove_empty_rows()
Dim mySh As Worksheet
Set mySh = Sheets("Sheet1")  'Sayfa ismini kendi doysanızdaki sayfa ismini girersiniz.

Application.ScreenUpdating = False
mySh.Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

End Sub

 

[halilerdem]

Hepinize teşekkürler