Bir listedeki satırları gri veya beyaz renge boyatma

burakturk

Altın Üye
Katılım
12 Şubat 2013
Mesajlar
52
Excel Vers. ve Dili
Türkçe Excel 2019
konuyu tekrar hareketlendireceğim ama bir sorum daha olacak,

bu kodlar içerisinde 2 tane değişkenim mecvut, birisi tablo aralığı diğeri ise hangi sütuna göre bu renklendirme şartlarının aranacağı.

bu makro çalıştırıldığında bu değişkenleri girmemi nasıl sağlayabilirim?

Mesela burada tablo A3:V arası renklendirme içinde C3:C sütunu seçilmiş, aynı tabloların farklı farklı versiyonları olduğu için kodları her dosyada yeniden düzenlemek biraz zor geldi, bir kaç deneme yaptım ama bir yerde mantık hatası yaptığımdan dolayı her satırı gri ve beyaz olarak döndürebildim, çözümü de bulamadım..

ayrıca sheet üzerinde tek satır var ise hata veriyor, 20 30 sheet olan dökümanlarım var, bu sayfaları atlatmak için ne yapabilirim?

şimdiden teşekkürler
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Option Explicit

Sub Renklendir()
    Dim Renklenecek_Alan As Range, Kriter_Sutunu As Integer
    Dim Renk As Integer, Alan As Range, Satir As Long, Zaman As Double
    
    On Error Resume Next
    Set Renklenecek_Alan = Application.InputBox("Renklendirmek istediğiniz alanı seçiniz.", "Hücre Seçimi", Type:=8)
    On Error GoTo 0
    
    If Renklenecek_Alan Is Nothing Then
        MsgBox "Lütfen renklendirmek istediğiniz hücre aralığını seçiniz!", vbCritical
        Exit Sub
    End If
    
    Kriter_Sutunu = Application.InputBox("Kriterlerinizin bulunduğu sütun indis sayısını giriniz.", "Kriter Alanı Seçimi", Type:=1)
    
    If Kriter_Sutunu = False Then
        MsgBox "Lütfen kriterlerinizin bulunduğu sütun indis sayısını giriniz!", vbCritical
        Exit Sub
    End If
        
    Zaman = Timer
    
    Renk = 15
    
    Renklenecek_Alan.Interior.ColorIndex = xlNone

    Satir = Renklenecek_Alan.Cells(1).Row

    For Each Alan In Renklenecek_Alan.Columns(1).Cells
        If Satir = Alan.Row Then
            Alan.Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex = Renk
        ElseIf Left(Cells(Alan.Row, Kriter_Sutunu), 11) = Left(Cells(Alan.Row - 1, Kriter_Sutunu), 11) Then
            Alan.Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex = _
            Alan.Offset(-1).Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex
        Else
            If Renk = 15 Then
                Renk = xlNone
            Else
                Renk = 15
            End If
            Alan.Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex = Renk
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 

burakturk

Altın Üye
Katılım
12 Şubat 2013
Mesajlar
52
Excel Vers. ve Dili
Türkçe Excel 2019
Deneyiniz.

C++:
Option Explicit

Sub Renklendir()
    Dim Renklenecek_Alan As Range, Kriter_Sutunu As Integer
    Dim Renk As Integer, Alan As Range, Satir As Long, Zaman As Double
   
    On Error Resume Next
    Set Renklenecek_Alan = Application.InputBox("Renklendirmek istediğiniz alanı seçiniz.", "Hücre Seçimi", Type:=8)
    On Error GoTo 0
   
    If Renklenecek_Alan Is Nothing Then
        MsgBox "Lütfen renklendirmek istediğiniz hücre aralığını seçiniz!", vbCritical
        Exit Sub
    End If
   
    Kriter_Sutunu = Application.InputBox("Kriterlerinizin bulunduğu sütun indis sayısını giriniz.", "Kriter Alanı Seçimi", Type:=1)
   
    If Kriter_Sutunu = False Then
        MsgBox "Lütfen kriterlerinizin bulunduğu sütun indis sayısını giriniz!", vbCritical
        Exit Sub
    End If
       
    Zaman = Timer
   
    Renk = 15
   
    Renklenecek_Alan.Interior.ColorIndex = xlNone

    Satir = Renklenecek_Alan.Cells(1).Row

    For Each Alan In Renklenecek_Alan.Columns(1).Cells
        If Satir = Alan.Row Then
            Alan.Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex = Renk
        ElseIf Left(Cells(Alan.Row, Kriter_Sutunu), 11) = Left(Cells(Alan.Row - 1, Kriter_Sutunu), 11) Then
            Alan.Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex = _
            Alan.Offset(-1).Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex
        Else
            If Renk = 15 Then
                Renk = xlNone
            Else
                Renk = 15
            End If
            Alan.Resize(, Renklenecek_Alan.Columns.Count).Interior.ColorIndex = Renk
        End If
    Next
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

teşekkür ediyorum, mantığını anladım ufak bir düzenleme daha ekledim ve gayet güzel çalıştırdım..

renklendirme kriterini de girişte soracak şekle sokacağım.

emeğiniz için teşekkür ediyorum.
 
Üst