Boş satır sil

[nadirornek]

Sub BosSatirlariSil()
Dim LastRow As Long, r As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
LastRow = LastRow + ActiveSheet.UsedRange.Row - 1
Application.ScreenUpdating = False
For r = LastRow To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r
End Sub

Aktif sayfamda boş satırları bu kod ile siliyorum yalnız biraz zaman alıyor daha kısa zamanda boş satırları silip dolu satırları yukarıya doğru nasıl alabilirim kod ile.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Bos_Satir_Sil()
    Dim Son As Long, X As Long, Alan As Range, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False

    Son = Cells.Find("*", Searchorder:=xlByRows, Searchdirection:=xlPrevious).Row

    For X = 1 To Son
        If Application.CountA(Rows(X)) = 0 Then
            If Alan Is Nothing Then
                Set Alan = Cells(X, 1)
            Else
                Set Alan = Union(Alan, Cells(X, 1))
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then
        Alan.EntireRow.Delete
        Application.ScreenUpdating = True
        MsgBox "Tespit edilen boş satırlar silinmiştir." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        Application.ScreenUpdating = True
        MsgBox "Silinecek satır bulunamadı!", vbCritical
    End If
End Sub

 

[nadirornek]

Korhan Bey 109,88 saniyede sildi.
Bu kodu 1500 satır ile alan belirleyerek yazarsanız birde öyle denesem daha kısa zamanda olabilirmi teşekkürler.

 

[Korhan Ayhan]

Uyguladığınız dosyayı görmek gerekir. Sizin ilk verdiğiniz kod da satırdaki dolu hücreler kontrol ediliyor. Satırda hiç veri yoksa siliniyor.

Eğer alanı daraltırsanız ya da dolu hücre kontrolü kaldırılırsa daha hızlı sonuca gidilebilir.

Kod içindeki "Son" değişkenine 1500 yazarsanız o kadar satırı kontrol edecektir. Bunu kendinizde yapabilirsiniz.

 

[nadirornek]

Teşkkürler

 

[Seyit Tiken]

Bu şekilde bir deneyiniz.

[a1:a5000].SpecialCells(4).EntireRow.Delete Shift:=xlUp