• DİKKAT

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

Kod çakışması.!

S

sensizsoldum

Katılım
10 Ekim 2010
Mesajlar
1,469
Excel Vers. ve Dili
2010 Türkçe
Merhaba, Aşağıda 3 farklı işlemlerde kullandığım aynı olayla çalışan kod var, kodların çalışmasında sıkıntı yok ama 3 aynı sayfada olunca kodların biri çalışsa diğeri, diğeri çalışsa öteki diğeri çalışmıyor. Yerlerini değiştiriyorum olmuyor. Bu üç kodun çalışması gerekiyor. Ne yapmamız gerekiyor acaba.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
'Listeyi gösterir
    Dim Bul As Range, S2 As Worksheet, Adres As String
    If Intersect(Target, Range("A3:A" & Rows.Count, "C3:C" & Rows.Count)) Is Nothing Then Exit Sub
    Cells(Target.Row, "M").Clear
    If Cells(Target.Row, "A") <> "" And Cells(Target.Row, "C") <> "" Then
        Set S2 = Sheets("GÖNDERİLENLER")
        Set Bul = S2.Range("A:A").Find(Cells(Target.Row, "C"), , , xlWhole)
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If Bul.Offset(0, 5) = Cells(Target.Row, "A") Then
                    With Cells(Target.Row, "M")
                        .Value = "Lİsteye Git"
                        .Font.Bold = True
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .Font.ColorIndex = 1
                    End With
                    Exit Do
                End If
                Set Bul = S2.Range("A:A").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
    End If
'B sütuna veri yazıldında A sütuna tarihi atar
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
If Target.Row < 3 Then Exit Sub
If Target <> "" Then Target.Offset(0, -1) = Date
'H sütuna sonuçları verir
If Intersect(Target, Range("D3:G" & Rows.Count)) Is Nothing Then Exit Sub
On Error Resume Next
Cells(Target.Row, "H") = "=IF(COUNTA(RC[-4]:RC[-1])=0,"""",RC[-4]*RC[-3]/100+IF(AND(RC[-2]<>0,RC[-1]<>0),(RC[-2]*MID(RC[-1],1,2)*MID(RC[-1],4,2))/15000,0))"
Cells(Target.Row, "H") = Cells(Target.Row, "H")

End Sub
 
Merhaba
Kodu bununla değiştirip dener misiniz_?
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Listeyi gösterir
On Error Resume Next
Application.EnableEvents = False
    Dim Bul As Range, S2 As Worksheet, Adres As String
    If Target.Column = 1 Then
    If Intersect(Target, Range("A3:A" & Rows.Count, "C3:C" & Rows.Count)) Is Nothing Then _
    Application.EnableEvents = True: Exit Sub
    Cells(Target.Row, "M").Clear
    If Cells(Target.Row, "A") <> "" And Cells(Target.Row, "C") <> "" Then
        Set S2 = Sheets("GÖNDERİLENLER")
        Set Bul = S2.Range("A:A").Find(Cells(Target.Row, "C"), , , xlWhole)
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If Bul.Offset(0, 5) = Cells(Target.Row, "A") Then
                    With Cells(Target.Row, "M")
                        .Value = "Lİsteye Git"
                        .Font.Bold = True
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .Font.ColorIndex = 1
                    End With
                    Exit Do
                End If
                Set Bul = S2.Range("A:A").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
    End If
'B sütuna veri yazıldında A sütuna tarihi atar
ElseIf Target.Column = 2 Then
If Intersect(Target, [B:B]) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
If Target.Row < 3 Then Application.EnableEvents = True: Exit Sub
If Target <> "" Then Target.Offset(0, -1) = Date
'H sütuna sonuçları verir
If Intersect(Target, Range("D3:G" & Rows.Count)) Is Nothing Then Exit Sub
Cells(Target.Row, "H") = "=IF(COUNTA(RC[-4]:RC[-1])=0,"""",RC[-4]*RC[-3]/100+IF(AND(RC[-2]<>0,RC[-1]<>0),(RC[-2]*MID(RC[-1],1,2)*MID(RC[-1],4,2))/15000,0))"
Cells(Target.Row, "H") = Cells(Target.Row, "H")
End If
Application.EnableEvents = True
End Sub
Not : Kod denemesi yapılmamıştır.
 
Merhaba Asi Bey,
Kodları denedim önceden 2 kod çalışıyordu, şimdi 1 kod çalışıyor o da tarihle ilgili olan.
 
Aşağıdaki gibi deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    'Listeyi gösterir
    Dim Bul As Range, S2 As Worksheet, Adres As String
    If (Target.Column = 1 Or Target.Column = 3) And Target.Row > 2 Then
        Cells(Target.Row, "M").Clear
        If Cells(Target.Row, "A") <> "" And Cells(Target.Row, "C") <> "" Then
            Set S2 = Sheets("GÖNDERİLENLER")
            Set Bul = S2.Range("A:A").Find(Cells(Target.Row, "C"), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Offset(0, 5) = Cells(Target.Row, "A") Then
                        With Cells(Target.Row, "M")
                            .Value = "Lİsteye Git"
                            .Font.Bold = True
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .Font.ColorIndex = 1
                        End With
                        Exit Do
                    End If
                    Set Bul = S2.Range("A:A").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    End If
    
    'B sütuna veri yazıldında A sütuna tarihi atar
    If Target.Column = 2 And Target.Row > 2 Then
        On Error Resume Next
        If Target <> "" Then Target.Offset(0, -1) = Date
        On Error GoTo 0
    End If

    'H sütuna sonuçları verir
    If Target.Column = 4 And Target.Row > 2 Then
        Cells(Target.Row, "H") = "=IF(COUNTA(RC[-4]:RC[-1])=0,"""",RC[-4]*RC[-3]/100+IF(AND(RC[-2]<>0,RC[-1]<>0),(RC[-2]*MID(RC[-1],1,2)*MID(RC[-1],4,2))/15000,0))"
        Cells(Target.Row, "H") = Cells(Target.Row, "H")
    End If
End Sub
 
Merhaba Korhan Bey,
İlginiz için çok teşekkür ediyorum. H sütuna gelen toplamalar kısmı randımanlı çalışmıyor, D ve E veya F ve G sütuna rakamlar girildiğinde H sütunda 0 geliyor toplamları vermiyor. İlgili hücrelerde ki değerler silindiğinde H sütundaki 0 kalıcı oluyor. Bu tıpkı formüllerin manuel olması gibi bir sorun. Örnek eklemek isterim ama şirkette olduğumdan ekleyemiyorum. Üzgünüm. Tarihle ilgili kodla yer değiştim fark yok yine aynı randımanlı çalışmadı. Sorun neden olabilir.
Tekrardan Çok teşekkür ediyorum. Çok sağ olun.
İyi çalışmalar dilerim.
 
Merhaba Korhan Bey,
Aşağıdaki şekilde denedim istediğim gibi çalışıyor, yanlış bir şeyler yapmadım ise yani kodda yanlış bir şey yoksa bu şekilde de kullanabilirim. Benim için önemli olan sorunsuz çalışmaması, ezbere bir şeyler yaptığım için sizlere sunmak istedim.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    'Listeyi gösterir
    Dim Bul As Range, S2 As Worksheet, Adres As String
    If (Target.Column = 1 Or Target.Column = 3) And Target.Row > 2 Then
        Cells(Target.Row, "M").Clear
        If Cells(Target.Row, "A") <> "" And Cells(Target.Row, "C") <> "" Then
            Set S2 = Sheets("GÖNDERİLENLER")
            Set Bul = S2.Range("A:A").Find(Cells(Target.Row, "C"), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Offset(0, 5) = Cells(Target.Row, "A") Then
                        With Cells(Target.Row, "M")
                            .Value = "Lİsteye Git"
                            .Font.Bold = True
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .Font.ColorIndex = 1
                        End With
                        Exit Do
                    End If
                    Set Bul = S2.Range("A:A").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    End If
    'B sütuna veri yazıldında A sütuna tarihi atar
    If Target.Column = 2 And Target.Row > 2 Then
        On Error Resume Next
        If Target <> "" Then Target.Offset(0, -1) = Date
        On Error GoTo 0
    End If
    ' H sütunda sonuçları verir
    If Intersect(Target, Range("D3:G" & Rows.Count)) Is Nothing Then Exit Sub
    Cells(Target.Row, "H") = "=IF(COUNTA(RC[-4]:RC[-1])=0,"""",RC[-4]*RC[-3]/100+IF(AND(RC[-2]<>0,RC[-1]<>0),(RC[-2]*MID(RC[-1],1,2)*MID(RC[-1],4,2))/15000,0))"
    Cells(Target.Row, "H") = Cells(Target.Row, "H")
    End
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst