Koşullu renklendirme

[serkanım]

Merhabalar

Hücre değerine göre koşullu renklendirme yapmak istiyorum.Hücrede herhangibir değer var ise hücre renginin değişmesini istiyorum.

Yardımınız için şimdiden teşekkür ederim.

 

[Ömer]

Merhaba,

ThisWorbook sayfasına kopyalayınız..

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, [E2:E65000]) Is Nothing Then Exit Sub
Set alan = Range("A" & Target.Row & ":E" & Target.Row)
 
    If Target = "" Then
        alan.Interior.ColorIndex = xlNone
    Else
        alan.Interior.ColorIndex = 15
        Range("B" & Target.Row).ClearContents
    End If
 
End Sub

.

 

[serkanım]

Merhaba Ömer Bey

Merhaba

E Sutununa herhangibir değer girdiğimde A ile E arası boyanıyor B sutunundaki veri siliniyor.Burada sorun yok.
Aynı işlemi K sutununa veri girdiğimde G ile K arasını boyamasını H sutununda bulunan verinin silinmesini istiyorum.

Bu işlemi ThisWorbook sayfasında değilde normal normal makro ile sayfa ismini girerek yapabilirmiyiz.
Sizi meşgul etmemek için çok uğraştım fakat içinden çıkamadım.
Teşekkürler

 

[Korhan Ayhan]

Selamlar,

Dosyanızdaki ThisWorkbook bölümündeki kodları silin ve aşağıdaki kodu "mart" isimli sayfanızın kod bölümüne uygulayın.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Alan1 As Range, Alan2 As Range
    
    On Error GoTo Son
    
    If Intersect(Target, [E2:E65536,K2:K65536]) Is Nothing Then Exit Sub
    If Target.Column = 5 Then
        Set Alan1 = Range("A" & Target.Row & ":E" & Target.Row)
        
        If Target = "" Then
            Alan1.Interior.ColorIndex = xlNone
        Else
            Alan1.Interior.ColorIndex = 15
            Range("B" & Target.Row).ClearContents
        End If
    ElseIf Target.Column = 11 Then
        Set Alan2 = Range("G" & Target.Row & ":K" & Target.Row)
        
        If Target = "" Then
            Alan2.Interior.ColorIndex = xlNone
        Else
            Alan2.Interior.ColorIndex = 15
            Range("H" & Target.Row).ClearContents
        End If
    End If
Son:
End Sub

 

[serkanım]

Tekrar Merhaba

Öncelikle vermiş olduğunuz destekten dolayı çok teşekkür ediyorum.
Yazmış olduğunuz kodlar tam istediğim gibi olmuş.
Affınıza sığınarak koşullu atama ile farklı bir sorum olacak.

Şimdiden teşekkürler..

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kullanılan kod;

Option Explicit
 
Sub SİPARİŞLERİ_KONTROL_ET()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Sayfalar(), X As Byte, Y As Long, Satır As Long
    
    Set S1 = Sheets("sipariş liste")
    Set S2 = Sheets("arşiv")
    
    Sayfalar = Array("makine 1", "makine 2")
    
    Satır = 2
    
    Application.ScreenUpdating = False
    
    S2.Range("A2:E65536").Clear
    
    For X = 0 To UBound(Sayfalar())
        For Y = 2 To Sheets(Sayfalar(X)).Range("A65536").End(3).Row
            If Sheets(Sayfalar(X)).Cells(Y, "A").Interior.ColorIndex <> xlNone Then
                If WorksheetFunction.CountIf(S1.Range("A:A"), Sheets(Sayfalar(X)).Cells(Y, "A")) = 0 Then
                    Sheets(Sayfalar(X)).Range("A" & Y & ":E" & Y).Cut S2.Range("A" & Satır)
                    Satır = Satır + 1
                End If
            End If
        Next
        
        For Y = 2 To Sheets(Sayfalar(X)).Range("G65536").End(3).Row
            If Sheets(Sayfalar(X)).Cells(Y, "G").Interior.ColorIndex <> xlNone Then
                If WorksheetFunction.CountIf(S1.Range("A:A"), Sheets(Sayfalar(X)).Cells(Y, "G")) = 0 Then
                    Sheets(Sayfalar(X)).Range("G" & Y & ":K" & Y).Cut S2.Range("A" & Satır)
                    Satır = Satır + 1
                End If
            End If
        Next
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[serkanım]

Merhaba Korhan Bey,

Hazırlamış olduğunuz makroyo 2 farklı koşul daha ilave etmenizi rica edebilirmiyim.Ekteki dosyaya açıklama yazdım.

Teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub SİPARİŞLERİ_KONTROL_ET()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Sayfalar(), X As Byte, Y As Long, Satır As Long
    
    Set S1 = Sheets("sipariş liste")
    Set S2 = Sheets("arşiv")
    
    Sayfalar = Array("makine 1", "makine 2")
    
    Satır = S2.Range("A65536").End(3).Row + 1
    
    Application.ScreenUpdating = False
    
    For X = 0 To UBound(Sayfalar())
        For Y = Sheets(Sayfalar(X)).Range("A65536").End(3).Row To 2 Step -1
            If Sheets(Sayfalar(X)).Cells(Y, "A").Interior.ColorIndex <> xlNone Then
                If WorksheetFunction.CountIf(S1.Range("A:A"), Sheets(Sayfalar(X)).Cells(Y, "A")) = 0 Then
                    Sheets(Sayfalar(X)).Range("A" & Y & ":E" & Y).Cut S2.Range("A" & Satır)
                    Sheets(Sayfalar(X)).Range("A" & Y & ":E" & Y).Delete
                    Satır = Satır + 1
                End If
            End If
        Next
        
        For Y = Sheets(Sayfalar(X)).Range("G65536").End(3).Row To 2 Step -1
            If Sheets(Sayfalar(X)).Cells(Y, "G").Interior.ColorIndex <> xlNone Then
                If WorksheetFunction.CountIf(S1.Range("A:A"), Sheets(Sayfalar(X)).Cells(Y, "G")) = 0 Then
                    Sheets(Sayfalar(X)).Range("G" & Y & ":K" & Y).Cut S2.Range("A" & Satır)
                    Sheets(Sayfalar(X)).Range("G" & Y & ":K" & Y).Delete
                    Satır = Satır + 1
                End If
            End If
        Next
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Selamlar,

Özel mesajla son kodun hatalı çalıştığını belirtmişsiniz. Haklısınız. Son silme olayını eklediğimiz için kod hatalı çalışıyordu. Döngüyü tersten başlatarak bu sorunu ortadan kaldırdım. Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

 

[serkanım]

Teşekkürler

Merhaba Korhan Bey,

Sabırla sorularıma kısa zaman içerisinde dönüş yaptığınızdan dolayı size çok teşekkür ederim.

Herşey gönlünüzce olsun..