Belirtilen Hücreler Boş İse Satır Sil

[mrwarrior]

Teşekkür ederim.ben yaptığınızı uyarlamıştım. tekrar teşekkür ederim.

 

[Vanhelsing7257]

Merhabalar . Öncelikle kod bilgim hiç yok . Yazdığım kodları da ben yazmadım . Şunu istiyorum eğer mümkünse buradaki kodlarla hücreleri birleştiriyorum veri kaybı olmadan . Buna ek olarak birleştirdiğim ve sonrasında boş olan satırların silinmesini istiyorum. Çünkü her seferinde boş olanları silmek zor oluyor . Teşekkürler şimdiden


Const seper As String = " " 'bİRLESTİRME aYİRACI."

Sub BirlestirdegerKaybetmeden()


Dim sRange As Range
Dim cll As Range
Dim tmpStr As String

Set sRange = Selection
If sRange.MergeCells = True Then Exit Sub
For Each cll In sRange.Cells
tmpStr = tmpStr & seper & CStr(cll.Value)
Next cll

tmpStr = Mid(tmpStr, Len(seper) + 1)

Application.DisplayAlerts = False
With sRange
.ClearContents
.Merge
.Value = tmpStr

End With
Application.DisplayAlerts = True

End Sub

 

[Erdogan3434]

Merhaba,

Satır silme işlemini tek tek yerine topluca yaparsanız kodlar biraz daha hızlı sonuç verecektir.

Deneyiniz. Kodu dosyanızda ki veriye göre revize etmek gerekebilir.

Option Explicit

Sub Sil()
    Dim X As Long, Son As Long, Alan As Range
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    On Error Resume Next
    Son = Cells.Find("*", Cells(1, 1), , , xlByRows, xlPrevious).Row
    On Error GoTo 0
   
    If Son > 1 Then
        For X = 2 To Son
            If WorksheetFunction.CountBlank(Range("C" & X & ":F" & X)) = 4 Then
                If Alan Is Nothing Then
                    Set Alan = Cells(X, "C")
                Else
                    Set Alan = Application.Union(Alan, Cells(X, "C"))
                End If
            End If
        Next
   
        If Not Alan Is Nothing Then Alan.EntireRow.Delete
    End If
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

Hocam öncelikle elinize sağlık. Bu kodu excelde bulunan tüm sayfalar için ilk açılışta uygulama şansımız var mı?

 

[Korhan Ayhan]

Merhaba,

Elbette var.. Kendi tablolarınıza göre uyarlarsınız.

Option Explicit

Sub Auto_Open()
    Dim WS As Worksheet, X As Long, Son As Long, Alan As Range
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For Each WS In ThisWorkbook.Worksheets
        On Error Resume Next
        Son = WS.Cells.Find("*", WS.Cells(1, 1), , , xlByRows, xlPrevious).Row
        On Error GoTo 0
       
        Set Alan = Nothing

        If Son > 1 Then
            For X = 2 To Son
                If WorksheetFunction.CountBlank(WS.Range("C" & X & ":F" & X)) = 4 Then
                    If Alan Is Nothing Then
                        Set Alan = WS.Cells(X, "C")
                    Else
                        Set Alan = Application.Union(Alan, WS.Cells(X, "C"))
                    End If
                End If
            Next
       
            If Not Alan Is Nothing Then Alan.EntireRow.Delete
        End If
    Next
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[Erdogan3434]

Korhan Hocam, Öğrenmek için son birşey sormak istiyorum. Bir excelin sadece adını belirttiğim sayfalarında başlangıçta silme işlemi uygulamak belirtmediklerimde silme işleminin olmamasını istiyorum. Size de zahmet olmazsa Koda yorum ekleyerek paylaşma imkanınız var mı?

 

[Korhan Ayhan]

Öncelikle bir önceki önerdiğim koda bir satır ekledim. Son haliyle daha sağlıklı çalışacaktır.

Son talebinize göre aşağıdaki yapı işinizi görecektir.

Option Explicit

Sub Auto_Open()
    Rem Değişkenleri tanımlıyoruz.
    Dim WS As Worksheet, X As Long, Son As Long, Alan As Range
 
    Rem Kodun hızlı çalışması için ekran hareketlerini ve hesaplama yöntemini pasif hale getiriyoruz.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Rem Dosyadaki adınız belirttiğimiz sayfaları işlem yapmak üzere döngüye alıyoruz.
    For Each WS In ThisWorkbook.Worksheets(Array("Sayfa1", "Sayfa2", "Sayfa3"))
        Rem Sayfadaki son dolu satırı tespit ediyoruz.
        On Error Resume Next
        Son = WS.Cells.Find("*", WS.Cells(1, 1), , , xlByRows, xlPrevious).Row
        On Error GoTo 0
       
        Rem Alan değişkenini sıfırlıyoruz.
        Set Alan = Nothing
      
        Rem İşlem yapılan sayfada 1 satırdan fazla veri varsa işleme devam ediyoruz.
        If Son > 1 Then
            Rem İşlem yapılan sayfada 2. satırdan itibaren son satıra kadar döngü oluşturuyoruz.
            For X = 2 To Son
                Rem C-F aralığındaki hücrelerde veri varmı kontrol ediyoruz.
                If WorksheetFunction.CountBlank(WS.Range("C" & X & ":F" & X)) = 4 Then
                    Rem Eğer C-F aralığında veri yoksa yani boşsa bu alana ait C hücresini silinecek satır olarak ALAN değişkenine yüklüyoruz.
                    If Alan Is Nothing Then
                        Set Alan = WS.Cells(X, "C")
                    Else
                        Rem Eğer ALAN değişkenine daha önce bir hücre yüklendiyse Union komutu ile hücreleri adres olarak birleştirerek işleme devam ediyoruz.
                        Set Alan = Application.Union(Alan, WS.Cells(X, "C"))
                    End If
                End If
                Rem Diğer satırların kontrolü için döngüye devam ediyoruz.
            Next
      
            Rem Bütün satırların kontrolü tamamlanınca ALAN değişkenine bazı hücre adresleri yüklenmiş olacaktır. Eğer ALAN değişkeni boş değilse yüklenmiş satırların tümünü sil diyoruz.
            If Not Alan Is Nothing Then Alan.EntireRow.Delete
        End If
        Rem İsmi tanımlanmış sıradaki sayfa için döngüye devam ediyoruz.
    Next
 
    Rem Kodun sonunda ekran hareketlerini ve hesaplama yöntemini tekrar aktif hale alıyoruz.
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    Rem İşlemin bittiğine ilişkin kullanıcıyı bilgilendiriyoruz.
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[Erdogan3434]

Öncelikle bir önceki önerdiğim koda bir satır ekledim. Son haliyle daha sağlıklı çalışacaktır.

Son talebinize göre aşağıdaki yapı işinizi görecektir.

Option Explicit

Sub Auto_Open()
    Rem Değişkenleri tanımlıyoruz.
    Dim WS As Worksheet, X As Long, Son As Long, Alan As Range

    Rem Kodun hızlı çalışması için ekran hareketlerini ve hesaplama yöntemini pasif hale getiriyoruz.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Rem Dosyadaki adınız belirttiğimiz sayfaları işlem yapmak üzere döngüye alıyoruz.
    For Each WS In ThisWorkbook.Worksheets(Array("Sayfa1", "Sayfa2", "Sayfa3"))
        Rem Sayfadaki son dolu satırı tespit ediyoruz.
        On Error Resume Next
        Son = WS.Cells.Find("*", WS.Cells(1, 1), , , xlByRows, xlPrevious).Row
        On Error GoTo 0
      
        Rem Alan değişkenini sıfırlıyoruz.
        Set Alan = Nothing
     
        Rem İşlem yapılan sayfada 1 satırdan fazla veri varsa işleme devam ediyoruz.
        If Son > 1 Then
            Rem İşlem yapılan sayfada 2. satırdan itibaren son satıra kadar döngü oluşturuyoruz.
            For X = 2 To Son
                Rem C-F aralığındaki hücrelerde veri varmı kontrol ediyoruz.
                If WorksheetFunction.CountBlank(WS.Range("C" & X & ":F" & X)) = 4 Then
                    Rem Eğer C-F aralığında veri yoksa yani boşsa bu alana ait C hücresini silinecek satır olarak ALAN değişkenine yüklüyoruz.
                    If Alan Is Nothing Then
                        Set Alan = WS.Cells(X, "C")
                    Else
                        Rem Eğer ALAN değişkenine daha önce bir hücre yüklendiyse Union komutu ile hücreleri adres olarak birleştirerek işleme devam ediyoruz.
                        Set Alan = Application.Union(Alan, WS.Cells(X, "C"))
                    End If
                End If
                Rem Diğer satırların kontrolü için döngüye devam ediyoruz.
            Next
     
            Rem Bütün satırların kontrolü tamamlanınca ALAN değişkenine bazı hücre adresleri yüklenmiş olacaktır. Eğer ALAN değişkeni boş değilse yüklenmiş satırların tümünü sil diyoruz.
            If Not Alan Is Nothing Then Alan.EntireRow.Delete
        End If
        Rem İsmi tanımlanmış sıradaki sayfa için döngüye devam ediyoruz.
    Next

    Rem Kodun sonunda ekran hareketlerini ve hesaplama yöntemini tekrar aktif hale alıyoruz.
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    Rem İşlemin bittiğine ilişkin kullanıcıyı bilgilendiriyoruz.
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

Hocam emeğinize, muhteşem eğitici yorumlamanıza ve sabrınıza ayrı ayrı teşekkür etmek istiyorum. Saygılarımla.