Kayıt Makrosu

[Muzaffer Ali]

Kodlar kopyala yapıştıra uygun değildi onun için hata veriyordu.
Revize edilmiş kodlar aşağıda.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim AktifHcreler As Range
    Dim Bak As Range
    Dim Hcr As Range
    Dim Renk1 As Variant
    Dim Renk2 As Variant
    On Error GoTo Hata:
    If Intersect(Target, Range("D:W")) Is Nothing Then Exit Sub
    Set AktifHcreler = Intersect(Target, Range("D:W"))
    For Each Bak In AktifHcreler
        If Not Intersect(Bak, Range("D:M")) Is Nothing Then
            Set Hcr = Bak(1, 11)
            Renk1 = 65535
            Renk2 = 5287936
        ElseIf Not Intersect(Bak, Range("N:W")) Is Nothing Then
            Set Hcr = Target(1, -9)
            Renk1 = 5287936
            Renk2 = 65535
        Else
            Exit Sub
        End If
        Application.EnableEvents = False
        If Bak = "" Or Hcr = "" Then
            Bak.Interior.Pattern = xlNone
            Hcr.Interior.Pattern = xlNone
        Else
            If Cells(Bak.Row, "C") = "üst" Then
                If Bak > Hcr Then
                    Bak.Interior.Color = Renk1
                    Hcr.Interior.Color = Renk1
                ElseIf Bak < Hcr Then
                    Bak.Interior.Color = Renk2
                    Hcr.Interior.Color = Renk2
                ElseIf Bak = Hcr Then
                    Bak.Interior.Pattern = xlNone
                    Hcr.Interior.Pattern = xlNone
                End If
            ElseIf Cells(Bak.Row, "C") = "alt" Then
                If Bak > Hcr Then
                    Bak.Interior.Color = Renk2
                    Hcr.Interior.Color = Renk2
                ElseIf Bak < Hcr Then
                    Bak.Interior.Color = Renk1
                    Hcr.Interior.Color = Renk1
                ElseIf Bak = Hcr Then
                    Bak.Interior.Pattern = xlNone
                    Hcr.Interior.Pattern = xlNone
                End If
            End If
        End If
    Next
Hata:
    Application.EnableEvents = True
End Sub

 

[uKiGS]

Yeni kodlar için teşekkür ederim. Emeğinize sağlık. Peki üst hücreye sayı yazdığımda alt hücreye otomatik olarak atması mümkün mü?

 

[Muzaffer Ali]

Bir de 2-4-6 Gibi çift satırlara ben sonuç yazınca otomatik olarak 1-3-5 gibi tek satırlara aynı sütuna üstteki sayıyı getirebilir mi?

Tam anlamadım Örnek olark D2 ye 30 yazınca D3 e de 30 mu yazacak?
Eğer D3 doluysa yine de yazacak mı?

 

[uKiGS]

Dosyanız ekte.

Tam anlamadım Örnek olark D2 ye 30 yazınca D3 e de 30 mu yazacak?
Eğer D3 doluysa yine de yazacak mı?

D2 ve D3 zaten hep aynı değerler olacak. Hatta hücre birleştirme yapılıp yazılabilir ama bu sefer yaptığınız formüller bozuluyor.

 

[Muzaffer Ali]

Kodların düzgün çalışması için "C" sütununda mutlaka "üst", "alt" yazması gerekiyor. Eğer yazmıyorsa kodlar çalışmaz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim AktifHcreler As Range
    Dim Bak As Range
    Dim Hcr As Range
    Dim Renk1 As Variant
    Dim Renk2 As Variant
    On Error GoTo Hata:
    If Intersect(Target, Range("D:W")) Is Nothing Then Exit Sub
    If Cells(Target.Row, "C") = "üst" And Target(2, 1) = "" Then Target(2, 1) = Target
    Set AktifHcreler = Intersect(Target, Range("D:W"))
    For Each Bak In AktifHcreler
        If Not Intersect(Bak, Range("D:M")) Is Nothing Then
            Set Hcr = Bak(1, 11)
            Renk1 = 65535
            Renk2 = 5287936
        ElseIf Not Intersect(Bak, Range("N:W")) Is Nothing Then
            Set Hcr = Target(1, -9)
            Renk1 = 5287936
            Renk2 = 65535
        Else
            Exit Sub
        End If
        Application.EnableEvents = False
        If Bak = "" Or Hcr = "" Then
            Bak.Interior.Pattern = xlNone
            Hcr.Interior.Pattern = xlNone
        Else
            If Cells(Bak.Row, "C") = "üst" Then
                If Bak > Hcr Then
                    Bak.Interior.Color = Renk1
                    Hcr.Interior.Color = Renk1
                ElseIf Bak < Hcr Then
                    Bak.Interior.Color = Renk2
                    Hcr.Interior.Color = Renk2
                ElseIf Bak = Hcr Then
                    Bak.Interior.Pattern = xlNone
                    Hcr.Interior.Pattern = xlNone
                End If
            ElseIf Cells(Bak.Row, "C") = "alt" Then
                If Bak > Hcr Then
                    Bak.Interior.Color = Renk2
                    Hcr.Interior.Color = Renk2
                ElseIf Bak < Hcr Then
                    Bak.Interior.Color = Renk1
                    Hcr.Interior.Color = Renk1
                ElseIf Bak = Hcr Then
                    Bak.Interior.Pattern = xlNone
                    Hcr.Interior.Pattern = xlNone
                End If
            End If
        End If
    Next
Hata:
    Application.EnableEvents = True
End Sub

Eğer alt satır dolu olsa çalışsın istiyorsanız.

If Cells(Target.Row, "C") = "üst" And Target(2, 1) = "" Then Target(2, 1) = Target

satırını silin

If Cells(Target.Row, "C") = "üst"  Then Target(2, 1) = Target

satırını kopyalayın

 

[uKiGS]

Çok zahmet verdirdim sizlere çok teşekkür ederim. Şu anda tam istediğim gibi olmuş.

Emeklerinize sağlık.