• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İki tane Worksheet_Change kodunun birleştirilmesi

M

merveileuse

Katılım
3 Ocak 2014
Mesajlar
6
Excel Vers. ve Dili
excel 10. pro
Merhaba;
Aşağıdaki iki kodu birarada kullanmanın bir yolu var mıdır?

Teşekkürler

Kod1
Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 6 Then
Target.Offset(0, 1).ClearContents
Target.Offset(0, 2).ClearContents
Target.Offset(0, 3).ClearContents
Target.Offset(0, 4).ClearContents
Target.Offset(0, 5).ClearContents
Target.Offset(0, 6).ClearContents
Target.Offset(0, 7).ClearContents
Target.Offset(0, 8).ClearContents
Target.Offset(0, 9).ClearContents
Target.Offset(0, 10).ClearContents
Target.Offset(0, 11).ClearContents
End If
End Sub

Kod2
Private Sub Worksheet_Change(ByVal Target As Range)
Set xxx = Intersect(Target, Range("E2:F32,H2:H32"))
If Not xxx Is Nothing Then
If HasValidation(xxx) Then
Exit Sub
Else
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Your last operation was cancelled. It would have deleted data validation rules.", vbCritical
End If
End If
End Sub

Private Function HasValidation(r) As Boolean
HasValidation = True
On Error Resume Next
For Each cll In r.Cells
x = cll.Validation.Type
If Err.Number <> 0 Then
HasValidation = False
Exit For
End If
Next cll
End Function
 
Merhaba.
Aşağıdaki kodları deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Column = 6 Then
        Range(Target.Offset(0, 1).Address, Target.Offset(0, 11).Address).ClearContents
    End If
    Set xxx = Intersect(Target, Range("E2:F32,H2:H32"))
    If Not xxx Is Nothing Then
        If HasValidation(xxx) Then
            Application.EnableEvents = True
            Exit Sub
        Else
            Application.Undo
            MsgBox "Your last operation was cancelled. It would have deleted data validation rules.", vbCritical
        End If
    End If
    Application.EnableEvents = True
End Sub

Private Function HasValidation(r) As Boolean
    HasValidation = True
    On Error Resume Next
    For Each cll In r.Cells
        x = cll.Validation.Type
        If Err.Number <> 0 Then
            HasValidation = False
            Exit For
        End If
    Next cll
End Function
 
dalgalikur' Alıntı:
Merhaba.
Aşağıdaki kodları deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Column = 6 Then
        Range(Target.Offset(0, 1).Address, Target.Offset(0, 11).Address).ClearContents
    End If
    Set xxx = Intersect(Target, Range("E2:F32,H2:H32"))
    If Not xxx Is Nothing Then
        If HasValidation(xxx) Then
            Application.EnableEvents = True
            Exit Sub
        Else
            Application.Undo
            MsgBox "Your last operation was cancelled. It would have deleted data validation rules.", vbCritical
        End If
    End If
    Application.EnableEvents = True
End Sub

Private Function HasValidation(r) As Boolean
    HasValidation = True
    On Error Resume Next
    For Each cll In r.Cells
        x = cll.Validation.Type
        If Err.Number <> 0 Then
            HasValidation = False
            Exit For
        End If
    Next cll
End Function
Genişletmek için tıkla ...

Merhaba;
Cevap için çok teşekkürler. Dosya ilk yaptığım değişikliklerde olması gerektiği gibi çalışıyor. Yani 6. sütunda bir değişiklik yaptığımda kalan sütunları sıfırlıyor ve validation olmayan bir yerden copy paste yaptığımda gerekli uyarıyı veriyor. Ancak aynı döngüyü ikinci kere yaptığımda 6. sütun için uyguladığımız kod çalışırken tekrar validation olmayan bir yerden copy paste yaptığımda önce debug ekranı çıkıyor ve sonra da kod tamamen geçersiz oluyor. Kodda Application.Undo satırı sarı ile işaretli olarak hata veriyor. Bu konuda ne yapabiliriz?
 
Bu kodları kullanarak neyi amaçlıyorsunuz?
Belki farklı bir çözüm bulunabilir.
 
dalgalikur' Alıntı:
Bu kodları kullanarak neyi amaçlıyorsunuz?
Belki farklı bir çözüm bulunabilir.
Genişletmek için tıkla ...
Elimde data validationlarla dolu bir dosya var. İlk kodda 6. sütundaki validationda farklı bir seçenek seçildiğinde sağ tarafında yer alan dataların sıfırlanmasını istiyorum ki kullanıcı validationları baştan seçsin.
İkinci kısımda ise dosyadan validationların kaldırılmasını engellemeye çalışıyorum. Farklı bir dosyadan bir veriyi alıp benim hazırladığım dosyaya copy-paste ile yapıştırıldığında hazırladığım validationlar gidiyor. Bunu engellemek için ilgili alanlarda validation olup olmadığının kontrolünü sağlamaya çalışıyorum.
Dosyadan copy-paste yapılmasını engelmemem mümkün değil, bu sefer kullanıcının işini çok zorlaştırmış olacağım. Benim amacım copy-pastei engellemek değil, sadece validationların korunması.
Umarım açıklayabilmişimdir.
 
Yani siz "E2:F32" ve "H2:H32" hücre aralığına hiçbir zaman başka yerden yapıştırma olmasın mı istiyorsunuz?
 
Hayır, yapıştırma yapılabilir ancak hücrelerde yer alan validationların bozulmasını istemiyorum.
 
Yaptığım testlerde hiçbir sorunla karşılaşmadım.
Bir de aşağıdaki kodları dener misiniz?

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Hata:
    Dim xxx As Object
    Application.EnableEvents = False
    If Target.Column = 6 Then
        Range(Target.Offset(0, 1).Address, Target.Offset(0, 11).Address).ClearContents
    End If
    Set xxx = Intersect(Target, Range("E2:F32,H2:H32"))
    If Not xxx Is Nothing Then
        If HasValidation(xxx) Then
            Application.EnableEvents = True
            Exit Sub
        Else
            Application.Undo
            MsgBox "Your last operation was cancelled. It would have deleted data validation rules.", vbCritical
        End If
    End If
Hata:
    Application.EnableEvents = True
End Sub

Private Function HasValidation(r) As Boolean
    Dim cll As Object
    Dim x As Object
    HasValidation = True
    On Error Resume Next
    For Each cll In r.Cells
        x = cll.Validation.Type
        If Err.Number <> 0 Then
            HasValidation = False
            Exit For
        End If
    Next cll
End Function

Şunu eklemem lazım.
Application.EnableEvents = False satırı bir eylem mesela hücrede bir değişiklik olduğunda bunu dikkate alma demektir.
daha sonra Application.EnableEvents = True satırı ile bunu eski haline alıyoruz.

Eğer siz kodları yarıda keser ve Application.EnableEvents = True satırı çalışmazsa eylemleri dikkate almayacağı için kodlar bir sonraki sefer hücrede bir değişiklik olduğunda çalışmayacaktır.
Yeniden kodların çalışması için yani Worksheet_Change olayının çalışşması için Application.EnableEvents = True kod satırını çalıştırmanız gerekmekte.

Eğer karşılaştığınız sorun buysa-bu olursa aşağıdaki kodu çalıştırın.

Kod: 
sub EylemleriCalistir()
Application.EnableEvents = True
end sub
 
Son verdiğiniz kodu denediğimde E ve H sütunlarında hiçbir seçim yapmama izin vermiyor:) Sanırım problem ikinci belirttiğiniz gibi çünkü ilk kez validationı silecek şekilde data yapıştırdığımda gerekli hatayı veriyor ancak ikinci seferde runtime error:1004-method undo of object_ application failed hatası veriyor. . Bu verdiğiniz kodu, ilk kodun hangi bölümüne eklemeliyim?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst