Satır renklendirme ve hücre değeri silme yardım lazım

[yusufymr]

Arkadaşlar bi örneğim var eğer j sütununda bitti yazıyorsa o satırın renklenmesini ve g sütunundaki adet yazan hücrenin silinmesini yapamadım yarım edin lütfen

 

[yusufymr]

Yardım edecek kimse yokmu

 

[yusufymr]

yardım bekliyorum

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Renklendirme koşullu biçimlendirme ile yapılmıştır.

Silme işlemi ise Sayfa1 aktif olduğunda size uyarı vererek ve onayınızı alarak gerçekleşmektedir.

Silme işlemini yapan kod; (Sayfanın kod bölümüne uygulayınız.)

Option Explicit
 
Private Sub Worksheet_Activate()
    Dim SAY As Integer, X As Long
    
    On Error GoTo Son
    
    SAY = WorksheetFunction.CountIf(Range("J:J"), "BİTTİ")
    If SAY = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If MsgBox(SAY & " adet abonelik süresi dolan kayıt bulunmaktadır. Bu kayıtları silmek istiyor musunuz?", vbCritical + vbYesNo) = vbYes Then
        For X = 3 To Cells(Rows.Count, 1).End(3).Row
            If Cells(X, "J") = "BİTTİ" Then Range("B" & X & ":J" & X).ClearContents
        Next
            
        Range("B3:J" & Rows.Count).Sort , Key1:=Range("B3")
    
    Else
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    End If
    
Son:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[yusufymr]

hocam çok teşekkür ederim dün çok yoğundum mesajınıjı görmemişim aynen istediğim gibi olmuş elinize sağlık çok teşekkür ederim hocam bi sorum olacak j sütununda bitti yazınca bir macro çalıştırılırmı ,otomatik nasıl çalıştırırız ilginize teşekkür ederim

 

[yusufymr]

Hocam bi değişiklik yapmak zorunda kaldım tekrar yardım edermisiniz
silinenlerin başka sayfaya aktarılması gerekli teşekkürler.

 

[yusufymr]

Hocam bi değişiklik yapmak zorunda kaldım tekrar yardım edermisiniz
silinenlerin başka sayfaya aktarılması gerekli teşekkürler. 6 nolu mesajda dosya ekli size zahmet olucak bi yardım ederseniz sevinirim

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Private Sub Worksheet_Activate()
    Dim SAY As Integer, X As Long, Satır As Long
    
    On Error GoTo Son
    
    SAY = WorksheetFunction.CountIf(Range("J:J"), "BİTTİ")
    If SAY = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If MsgBox(SAY & " adet abonelik süresi dolan kayıt bulunmaktadır. Bu kayıtları BİTTİ isimli sayfaya aktarmak istiyor musunuz?", vbCritical + vbYesNo) = vbYes Then
        For X = 3 To Cells(Rows.Count, 1).End(3).Row
            If Cells(X, "J") = "BİTTİ" Then
            With Sheets("BİTTİ")
                Satır = .Range("B65536").End(3).Row + 1
                .Range("B" & Satır & ":I" & Satır).Value = Range("B" & X & ":I" & X).Value
                Range("B" & X & ":H" & X).ClearContents
            End With
            End If
        Next
            
        Range("A3:J" & Rows.Count).Sort , Key1:=Range("A3")
    
    Else
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    End If
    
Son:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[yusufymr]

hocam ilginize teşekkürler kod silme yapıyor fakat bitti sayfasına aktarmıyor

 

[Korhan Ayhan]

Selamlar,

Kod normalde aktarım yapıyor. Fakat sizin BİTTİ isimli sayfanızda alt satırlarda (61. satırdan sonra) veriler var. Bunları silip denerseniz aktardığını görebilirsiniz.

 

[yusufymr]

hocam allah razı olsun işimi hallettiniz çok teşekkür ederim kod çalışıyor çok işime yarayacak sağolun varolun

 

[subutayı]

merhaba ben bu örneği indirdim ama çalıştıramadım. bitti sayfasına silinenleri kayıt yapmıyor. örnek dosya eklerseniz sevinirim. teşekürler

 

[yusufymr]

Merhaba dosya bu çalışıyor ben bi değişiklik daha yaptım biten aboneler yanileme tarihi girilince tekrar aboneler sayfasına kopyalıyor