Soru Makro İle Koşullu Satır Boyama

[leonadies]

Değerli Üstadlar;

Koşullu biçimlendirmeyi kullanmayı istemediğim için, Aşağıdaki Kod ile satır boyama yapmaktayım. "G:G" gütununda "HAZIR" yazanları boyamakta. Makro sorunsuz çalışıyor ancak örneğin "G4:G15" toplu seçip DELTE ile sildiğimde satırlar hala boyalı kalıyor. Ama tek tek silsem hiç sorun yok çalışıyor. Kurguma nasıl bir ekleme/düzeltme yapmalıyım?

Dosyalarım Ekte.

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next
Application.ScreenUpdating = False

If Intersect(Target, [G:G]) Is Nothing Then Exit Sub
Range(Cells(Target.Row, 1), Cells(Target.Row, 17)).Interior.ColorIndex = xlNone


If Range("G" & Target.Row) = "" Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 17)).Interior.ColorIndex = xlNone
End If


If Range("G" & Target.Row) = "HAZIR" Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 17)).Interior.ColorIndex = 8
End If


Application.ScreenUpdating = True

End Sub

 

[muygun]

Merhaba;

Sayfadaki kodları aşağıdaki kodlarla değiştirerek deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
For i = 1 To Range("g65536").End(xlUp).Row
If Cells(i, "g") = "" Then
Range("a" & i & ":q" & i).Interior.ColorIndex = xlNone
End If
If Cells(i, "g") = "HAZIR" Then
Range("a" & i & ":q" & i).Interior.ColorIndex = 8
End If
Next i
Application.ScreenUpdating = True
End Sub


İyi çalışmalar.

 

[veyselemre]

Private Sub Worksheet_Change(ByVal Target As Range)
    Set Rng = Intersect(Target, [G:G])
    If Rng Is Nothing Then Exit Sub
    For Each r In Rng
        If r.Value <> "HAZIR" Then
            Cells(r.Row, 1).Resize(, 17).Interior.ColorIndex = xlNone
        Else
            Cells(r.Row, 1).Resize(, 17).Interior.ColorIndex = 8
        End If
    Next r
End Sub

 

[leonadies]

Çok teşekkürler üstadlarım @veyselemre ve @muygun Başka arkadaşlara da faydalı olması dileğiyle

 

[leonadies]

@veyselemre üstadım. Bu kodlar güzel çalışıyor ancak dosyam inanılmaz şişiyor. 500 Satırda 46 mb ları gördüm. Durumları silsemde boyut yine düşmüyor.

 

[leonadies]

Merhaba;

Sayfadaki kodları aşağıdaki kodlarla değiştirerek deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
For i = 1 To Range("g65536").End(xlUp).Row
If Cells(i, "g") = "" Then
Range("a" & i & ":q" & i).Interior.ColorIndex = xlNone
End If
If Cells(i, "g") = "HAZIR" Then
Range("a" & i & ":q" & i).Interior.ColorIndex = 8
End If
Next i
Application.ScreenUpdating = True
End Sub


İyi çalışmalar.

@muygun hocam boyama işleminde sorun yok ancak silince düzelmiyor malesef.

 

[Korhan Ayhan]

Alternatif;

"G" sütununu seçip tüm hücrelere HAZIR yazarsanız biraz bekletecektir. Bunun dışında sorun çıkarmadan çalışacaktır.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Veri As Range, Alan As Range
    
    On Error GoTo Son
    
    Application.ScreenUpdating = 0
    Application.EnableEvents = 0
    
    If Not Intersect(Target, Range("G:G")) Is Nothing Then
        If WorksheetFunction.CountA(Intersect(Target, Range("G:G"))) = 0 Then
            Cells(Target.Row, "A").Resize(Target.Rows.Count, 17).Interior.ColorIndex = xlNone
        Else
            For Each Veri In Intersect(Target, Range("G:G"))
                If UCase(Replace(Replace(Veri.Value, "ı", "I"), "i", "İ")) = "HAZIR" Then
                    If Alan Is Nothing Then
                        Set Alan = Cells(Veri.Row, "A").Resize(, 17)
                    Else
                        Set Alan = Union(Alan, Cells(Veri.Row, "A").Resize(, 17))
                    End If
                End If
            Next
            If Not Alan Is Nothing Then Alan.Interior.ColorIndex = 8
        End If
    End If

Son:
    Application.EnableEvents = 1
    Application.ScreenUpdating = 1
End Sub

 

[veyselemre]

@veyselemre üstadım. Bu kodlar güzel çalışıyor ancak dosyam inanılmaz şişiyor. 500 Satırda 46 mb ları gördüm. Durumları silsemde boyut yine düşmüyor.

Kodlarla alakası olmayan bir durum. Bu sistemle test için bile bir kez kullanmış olduğunuz en son satır dosyanızın usedrange alanını genişletecektir. Dolayısıyla dosyanız büyümüş olacaktır. Yani bir kez 1 milyonuncu satırın g sutununda bir işlem yaparsanız sayfanızın usedrange alanı 1milyon * 17 satır olacaktır. Kodu pasif edip dolu en son satırınızdan en sonuncu satıra kadar satırları silerseniz dosya boyutu düşmesi gerekir, yoksa 500 satırda 52kb oldu ancak.

 

[muygun]

Merhaba;

@muygun hocam boyama işleminde sorun yok ancak silince düzelmiyor malesef.

Ben denemelerimde bir sorun göremedim. Toplu yada tek silme yaparak (delete ile silin) deneyin.