a sutunundan hücreyi silince

[tahsinanarat]

ekteki dosyayı yeni gelen ürünlerin kodlarını girip eski datakod sayfasındaki fiatlar ile karşılaştırmak amacıyla hazırladım, Buraya kadar sorun yok.

Yapmak istediğim a sütunundaki bir ürün kodunu silince aynı satırdaki B, K ve L sütunundaki bilgilerin de silinmesini istiyorum,

Ayrıca M sütunundaki çıkartma işleminde DEĞER hatasını da giderebilirsek iyi olur. İlgilenecek arkadaşlarımı şimdiden teşekkür ederim.

 

[tahsinanarat]

Private Sub Worksheet_Change(ByVal target As Range)
On Error GoTo son
ActiveSheet.Unprotect
    If IsEmpty(target) Then Exit Sub

    If Intersect(target, [A:A]) Is Nothing Then Exit Sub
If target.Value = "" Then
    target.Interior.ColorIndex = xlNone
    target.Offset(0, 1) = ""
Else
    Set BUL = Sheets("Datakod").Columns("A").Find(target, LookAt:=xlWhole)
    If BUL Is Nothing Then
        'target.Interior.ColorIndex = 3
        'target.Offset(0, 1) = ""
        'MsgBox target.Value & " Degerini Bulamadim "
    Else
     
        target.Interior.ColorIndex = xlNone
        target.Offset(0, 1) = Sheets("datakod").Cells(BUL.Row, "B")
        target.Offset(0, 10) = Sheets("datakod").Cells(BUL.Row, "e")
        target.Offset(0, 11) = Sheets("datakod").Cells(BUL.Row, "g")
        'Target.Offset(, 1).Next.Select
        'degistir
   End If
End If
If Intersect(target, [A:A]) Is Nothing Then Exit Sub
If target = 0 And target <> "" Then
Range("B" & target.Row & ":G" & target.Row).ClearContents
    End If
If target = 0 And target <> "" Then
Range("K" & target.Row & ":L" & target.Row).ClearContents
    End If
If target = 0 And target <> "" Then
Range("A" & target.Row).ClearContents
    End If
ActiveSheet.Protect

son:
End Sub

Yukarıdaki sorunun çözülmüş hali, A Sutununa 0 (sıfır) yazınca istediğim hücreleri
If Intersect(target, [A:A]) Is Nothing Then Exit Sub
If target = 0 And target <> "" Then
Range("B" & target.Row & ":G" & target.Row).ClearContents
End If
If target = 0 And target <> "" Then
Range("K" & target.Row & ":L" & target.Row).ClearContents
End If
If target = 0 And target <> "" Then
Range("A" & target.Row).ClearContents
End If

bu kodlarla halledebildim,
BCDEFG VE KL sutundaki hücreleri silme işlemini tek satırda halledilebilirmi

 

[Korhan Ayhan]

Deneyiniz.

Kendinize göre uyarlarsınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    X = Target.Row
    Range("B" & X & ":G" & X & ",K" & X & ":L" & X).ClearContents
End Sub

 

[tahsinanarat]

Sn. Korhan hocam cevabınız için teşekkür ederim. Run_time error "28" hatası veriyor ve ayrıca H,I,J sütunundaki formülleri de siliyor, formüllerin silinmemesi lazım.

 

[tahsinanarat]

hata tuzaklaması koyunca sorunsuz çalıştı hocam. Teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    X = Target.Row
    Range("B" & X & ":G" & X & ",K" & X & ":L" & X).ClearContents
End Sub

2 nolu mesajımdaki kodun içine entegre edemedim.

 

[Korhan Ayhan]

Tam kontrol etmedim. Ama sanırım aşağıdaki kod işinizi görecektir.

Ayrıca bir önceki verdiğim kod H-I-J sütunlarına dokunmuyor. Sizin formüllerinizde hata verirse boşluk ekle koşulu olduğu için boş görünüyor.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    ActiveSheet.Unprotect
    
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If IsEmpty(Target) Then
        X = Target.Row
        Range("B" & X & ":G" & X & ",K" & X & ":L" & X).ClearContents
        Target.Interior.ColorIndex = xlNone
        Target.Offset(0, 1) = ""
    Else
        Set BUL = Sheets("Datakod").Columns("A").Find(Target, LookAt:=xlWhole)
        If Not BUL Is Nothing Then
            Target.Interior.ColorIndex = xlNone
            Target.Offset(0, 1) = Sheets("datakod").Cells(BUL.Row, "B")
            Target.Offset(0, 10) = Sheets("datakod").Cells(BUL.Row, "e")
            Target.Offset(0, 11) = Sheets("datakod").Cells(BUL.Row, "g")
       End If
    End If
Son:
    ActiveSheet.Protect
End Sub

 

[tahsinanarat]

Korhan hocam elinize sağlık, tam istediğim gibi olmuş.