Vba ile birer satır arayla koşullu biçimlendirme

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
Arkadaşlar selamlar
Bir excel sayfasında
önce aktif olan sayfadaki varsa tüm koşullu biçimlendirmeleri kaldırıp
sonra
A1>0 ise A1-L1 satırının dolgusunu gri renkli yap ve satırın çerçevesini çiz (hücre içlerini değil)
A2>0 ise A2-L2 satırınına dolgu yapma, sadece satırın çerçevesini çiz (hücre içlerini değil)
diye bir dolgulu bir dolgusuz kendini tekrarlayan koşullu biçimlendirme yapmak için nasıl bir vba kodu oluşturmalıyız?
Yardımcı olacak arkadaşlara şimdiden teşekkürler
(örnek biçimlendirme ekteki dosyada)
 

Ekli dosyalar

Son düzenleme:

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
çok teşekkürler, olorindex 48 çok koyu geldi. daha açık olması için ne yapmam lazım onu araştırıyorum. istediğim koyuluk dolgu menüsünde "%15 daha koyu" olan seçenek. Sol üstten üçüncü
 
Katılım
11 Temmuz 2024
Mesajlar
208
Excel Vers. ve Dili
Excel 2021 Türkçe
Merhabalar, şu şekilde dener misiniz;

Kod:
Sub KosulluBicimlendirmeUygula()
    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long
    Dim toggle As Boolean
    Dim rng As Range
    Dim griRenk As Long
    Set ws = ActiveSheet
    ws.Cells.FormatConditions.Delete
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    toggle = True
    griRenk = RGB(217, 217, 217)
    For i = 1 To sonSatir
        If ws.Cells(i, "A").Value > 0 Then
            Set rng = ws.Range(ws.Cells(i, "A"), ws.Cells(i, "L"))
            With rng.Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                rng.Borders(xlInsideVertical).LineStyle = xlNone
            End With
            If toggle Then
                rng.Interior.Color = griRenk
            Else
                rng.Interior.ColorIndex = xlNone
            End If
            toggle = Not toggle
        End If
    Next i
    MsgBox "Koşullu biçimlendirme tamamlandı.", vbInformation
End Sub
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
teşekkür ederim arkadaşlar, ikisi de işimi gördü.
 

Korhan Ayhan

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

Hız olarak avantaj sağlayabilir..

C++:
Option Explicit

Sub My_Conditional_Formatting()
    Dim My_Data As Variant, Cells_Address As String
    Dim X As Long, X_Rng As Object, Y_Rng As Object
    Dim My_Check As Boolean, Rng As Variant, Process_Time As Double
    
    Process_Time = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    With Range("A:L")
        .FormatConditions.Delete
        .Borders.LineStyle = xlNone
        .Interior.Color = xlNone
    End With
    
    My_Data = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Value
    
    Set X_Rng = CreateObject("Scripting.Dictionary")
    Set Y_Rng = CreateObject("Scripting.Dictionary")

    For X = LBound(My_Data) To UBound(My_Data)
        If My_Data(X, 1) > 0 And X Mod 2 = 1 Then X_Rng.Add "A" & X & ":L" & X, False
        If My_Data(X, 1) > 0 And X Mod 2 = 0 Then Y_Rng.Add "A" & X & ":L" & X, False
    Next
    
    For Each Rng In X_Rng.Keys
        My_Check = False
        If Len(Cells_Address & Rng & ",") <= 256 Then
            Cells_Address = Cells_Address & Rng & ","
        Else
            Range(CStr(Left(Cells_Address, Len(Cells_Address) - 1))).BorderAround xlContinuous
            Cells_Address = Rng & ","
            My_Check = True
        End If
    Next
    
    If My_Check = False Then
        Range(CStr(Left(Cells_Address, Len(Cells_Address) - 1))).BorderAround xlContinuous
    End If
    
    Cells_Address = ""
    
    For Each Rng In Y_Rng.Keys
        My_Check = False
        If Len(Cells_Address & Rng & ",") <= 255 Then
            Cells_Address = Cells_Address & Rng & ","
        Else
            Range(CStr(Left(Cells_Address, Len(Cells_Address) - 1))).BorderAround xlContinuous
            Range(CStr(Left(Cells_Address, Len(Cells_Address) - 1))).Interior.Color = RGB(217, 217, 217)
            Cells_Address = Rng & ","
            My_Check = True
        End If
    Next
    
    If My_Check = False Then
        Range(CStr(Left(Cells_Address, Len(Cells_Address) - 1))).BorderAround xlContinuous
        Range(CStr(Left(Cells_Address, Len(Cells_Address) - 1))).Interior.Color = RGB(217, 217, 217)
    End If
    
    Cells_Address = ""
    Erase My_Data
    Set X_Rng = Nothing
    Set Y_Rng = Nothing
        
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    MsgBox "Satır biçimlendirme işlemi tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
gerçekten çok hızlı hocam. ancak

With Range("A:L") 'bunu misal a4 ile L1000 olarak değiştirmek istesek nasıl düzenlemeliyiz?
.FormatConditions.Delete
.Borders.LineStyle = xlNone
.Interior.COLOR = xlNone
"......................................." ve buraya biçimlendirmeler dışında ayrıca hücrelerdeki tüm içeriği de silmesini istesek nasıl bir satır eklemeliyiz?

selamlar saygılar
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,708
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aşağıdaki gibi düzenleyebilirsiniz.

C++:
    With Range("A4:L1000")
        .FormatConditions.Delete
        .Borders.LineStyle = xlNone
        .Interior.Color = xlNone
        .ClearContents
    End With
Fakat kod A sütunundaki sayısal değerlere bakarak işlem yaptığı için düzgün sonuç vermeyecektir. Çünkü değerleri temizlemiş oluyoruz.
 
Üst