Q:AG aralığı boş ise AH:AU aralığındaki hücreler temizlensin

[kelkitli]

Merhabalar Değerli Dostlar,
Hazırlamaya çalıştığım puantaj tablosunda 2. satırdan 70. satıra kadar sırayla
Q:AG aralığı tamamen boş ise AH:AU aralığındaki hücreler temizlensin tek bir hücrede veri var ise işlem yapılmadan bir sonraki satıra geçilsin istiyorum. Yapabilen arkadaşlardan yardım bekliyorum.

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub Sil()
Dim kontrol As Boolean
Set s1 = Sheets("PUANTAJ")
For i = 2 To s1.[a65536].End(3).Row
kontrol = False
For Each c In Range(Cells(i, "q"), Cells(i, "ag"))
If c.Value <> "" Then kontrol = True
Next
If kontrol = False Then Range(Cells(i, "ah"), Cells(i, "au")).ClearContents
Next i
Set s1 = Nothing
MsgBox "Bitti"
End Sub

Not: A kolonundaki son kişiye kadar işlem yapmaktadır.

 

[kelkitli]

Öncelikle cevap verdiğiniz için çok teşekkür ederim Sn.Ripek.
Ancak şöyle bir sorun oldu. Aşağıda yazılı olan kodlarla AH2:AU68 alanını yazıp dolu hala getiriyordum. Şimdi sizin yazdığınızkodlarla silince artık kalıyor.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim hucre As Range
On Error GoTo hata
If Intersect(Target, [AV2]) Is Nothing Then Exit Sub
For Each hucre In [AH2:AU68]
If hucre = "" Then
hucre = Target.Value
End If
Next
hata:
End Sub

Bu kodunda End(3).Row mantığına uyarlanması lazım. Ben yapamadım.

 

[Recep İpek]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim hucre As Range
On Error GoTo hata
If Intersect(Target, [AV2]) Is Nothing Then Exit Sub
'***************************************************
Dim kontrol As Boolean
Set s1 = Sheets("PUANTAJ")
For i = 2 To s1.[a65536].End(3).Row
kontrol = False
For Each c In Range(Cells(i, "q"), Cells(i, "ag"))
If c.Value <> "" Then kontrol = True
Next
If kontrol = False Then Range(Cells(i, "ah"), Cells(i, "au")).ClearContents
Next i
Set s1 = Nothing
'*****************************************************
For Each hucre In [AH2:AU68]
    If hucre = "" Then
        hucre = Target.Value
    End If
Next
hata:
End Sub

olarak deneyin.

Buradaki kodlar önceki mesajımda yazdığım gibi A kolunundaki son dolu hücre sayısı kadar işlem yapıyor.
AH55:AU68 alanınında yaka numaralarını girerseniz tümü dikkate alınacaktır.

 

[kelkitli]

Sn.ripek,
Kodu denedim, A sütunundaki son satırdan sonra 68 satıra kadar yine yazıyor.
Yani son yaka numarasında yazma işlemini durdurmuyor.

 

[Recep İpek]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim hucre As Range
On Error GoTo hata
If Intersect(Target, [AV2]) Is Nothing Then Exit Sub
'***************************************************
Dim kontrol As Boolean
Set s1 = Sheets("PUANTAJ")
For i = 2 To s1.[a65536].End(3).Row
kontrol = False
For Each c In Range(Cells(i, "q"), Cells(i, "ag"))
If c.Value <> "" Then kontrol = True
Next
If kontrol = False Then
Range(Cells(i, "ah"), Cells(i, "au")).ClearContents
Range(Cells(i, "ah"), Cells(i, "au")).Value = Target.Value
End If
Next i
Set s1 = Nothing
'*****************************************************
hata:
End Sub

Kodlarını denermisiniz.

 

[kelkitli]

Sn.ripek sanıyorum eksik bilgi aktardım. Özet olarak şöyle olmalı. AH:AU aralığı Yaka numaralarının en son satırına kadar AV2 hücresine yazılan değeri boş olan hürelere yazdırmalı. (Bu kısma hafta tatilleri önceden işleniyor.) Dolu olan hücrelere dokunulmamalı.
Sn.Ripek bu tablo hazırlamış olduğum programa eklenecek. Hazırladığım bölüm hafta tatllrini ve diğer bilgileri giriyor.

 

[kelkitli]

Sn.ripek yada şöylede yapabiliriz. Sizin önce yazdığınız kodda Q:AG aralıığı boşsa AH:AU aralığı silinsin dediğimiz kısma yaka numarasının olduğu hücre ve Q:AG aralığı değerlerinin 2 sinden birisi boş olursa AH:AU aralığı silinsin dersek de olur.

 

[kelkitli]

Sn.ripek sizi yordum hakkınızı helal edin. Teşekkür ederim emek çektiniz.
Kodu şu şekil kullanırsam benim işimi görür.

Sub Sil()
Dim kontrol As Boolean
Set s1 = Sheets("PUANTAJ")
For i = 2 To 100
kontrol = False
For Each c In Range(Cells(i, "q"), Cells(i, "ag"))
If c.Value <> "" Then kontrol = True
Next
If kontrol = False Then Range(Cells(i, "ah"), Cells(i, "au")).ClearContents
Next i
Set s1 = Nothing
MsgBox "Bitti"
End Sub