• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Aktif Hücrenin Bulunduğu Satırı Vurgulama

P

poetika

Altın Üye
Katılım
6 Kasım 2005
Mesajlar
142
Excel Vers. ve Dili
Excel 2010 Türkçe
excel tablom a1 q50000 arasında.
q sütunundaki veriye göre tablo içeriğindeki ilgili satırı renklendiren bir makrom var.
bunun yanında tabloda aktif hücrenin bulunduğu satırın vurgulanmasını istiyorum. ancak bahsettiğim renklendirme makromla çakışmamalı ve renklendirmeler bozulmamalı. bu mümkün müdür?
 
Kod: 
Dim PreviousCell As Range
Dim PreviousColor As Variant
Dim WasColored As Boolean

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' Önceki hücrenin rengini geri yükle
    If Not PreviousCell Is Nothing Then
        On Error Resume Next
        If WasColored Then
            PreviousCell.Interior.Color = PreviousColor
        Else
            PreviousCell.Interior.ColorIndex = xlColorIndexNone
        End If
        On Error GoTo 0
    End If

    ' Yeni hücre geçerli aralıkta mı?
    If Not Intersect(Target, Me.Range("A1:Q50000")) Is Nothing Then
        Set PreviousCell = Target.Cells(1, 1)

        ' Önceki rengi kaydet
        If PreviousCell.Interior.ColorIndex = xlColorIndexNone Then
            WasColored = False
        Else
            WasColored = True
            PreviousColor = PreviousCell.Interior.Color
        End If

        ' Aktif hücreyi vurgula (örneğin açık mavi)
        PreviousCell.Interior.Color = RGB(204, 255, 255)
    End If
End Sub

dener misin.
 
Ali' Alıntı:
Kod: 
Dim PreviousCell As Range
Dim PreviousColor As Variant
Dim WasColored As Boolean

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' Önceki hücrenin rengini geri yükle
    If Not PreviousCell Is Nothing Then
        On Error Resume Next
        If WasColored Then
            PreviousCell.Interior.Color = PreviousColor
        Else
            PreviousCell.Interior.ColorIndex = xlColorIndexNone
        End If
        On Error GoTo 0
    End If

    ' Yeni hücre geçerli aralıkta mı?
    If Not Intersect(Target, Me.Range("A1:Q50000")) Is Nothing Then
        Set PreviousCell = Target.Cells(1, 1)

        ' Önceki rengi kaydet
        If PreviousCell.Interior.ColorIndex = xlColorIndexNone Then
            WasColored = False
        Else
            WasColored = True
            PreviousColor = PreviousCell.Interior.Color
        End If

        ' Aktif hücreyi vurgula (örneğin açık mavi)
        PreviousCell.Interior.Color = RGB(204, 255, 255)
    End If
End Sub

dener misin.
Genişletmek için tıkla ...

teşekkürler ama kodu yükleyince herhangi bir işlem yapmadı. vurgulama oluşmadı.
 
kodda sorun yok aktif hücre renklenmektedir.başka bir boş excel dosyasına kodu yapıştırıp deneyiniz.
örnek dosyanızı paylaşırsanız çakışmamı var bakılabilir
 
muhasebeciyiz' Alıntı:
kodda sorun yok aktif hücre renklenmektedir.başka bir boş excel dosyasına kodu yapıştırıp deneyiniz.
örnek dosyanızı paylaşırsanız çakışmamı var bakılabilir
Genişletmek için tıkla ...

Kod: 
Sub GenelListeyiRenklendir_HIZLI()
    Dim Sh As Worksheet
    Set Sh = ThisWorkbook.Sheets("Genel Liste")

    Dim sonSatir As Long
    sonSatir = Sh.Cells(Sh.Rows.Count, "Q").End(xlUp).Row
    If sonSatir < 2 Then Exit Sub

    Dim veriAralik As Variant
    Dim renkAralik() As Long
    Dim i As Long
    Dim durum As String

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' Q sütunundaki verileri al
    veriAralik = Sh.Range("Q2:Q" & sonSatir).Value
    ReDim renkAralik(1 To UBound(veriAralik, 1))

    ' Renkleri belirle
    For i = 1 To UBound(veriAralik, 1)
        durum = Trim(veriAralik(i, 1))

        Select Case durum
            Case "DOSYA BİRLEŞTİRİLDİ", "TAKİP ÖNCESİ TAHSİL EDİLDİ", "İCRA YOLUYLA TAHSİL EDİLDİ", _
                 "İPTAL EDİLDİ", "MÜKERRER SATIR", "TAHSİL EDİLDİ", "TERKİN EDİLDİ (PARASAL SINIR ALTI)", "TERKİN EDİLDİ (VEFAT)", "TERKİN EDİLDİ (MAHKEME KARARI)"
                renkAralik(i) = RGB(198, 239, 206) ' yeşil

            Case "DOSYA BULUNAMADI", "İCRAYA GÖNDERİLDİ", "SORUNLU İNCELENİYOR"
                renkAralik(i) = RGB(255, 220, 225) ' turuncu

            Case "İADE OLDU", "MERNİS ADRESİ BULUNAMADI"
                renkAralik(i) = RGB(255, 242, 204) ' altın

            Case "TAKSİTLENDİRME YAPILDI"
                renkAralik(i) = RGB(221, 235, 247) ' mavi

            Case Else
                renkAralik(i) = -1 ' renksiz bırak
        End Select
    Next i

    ' Önce tüm renkleri temizle
    Sh.Range("A2:Q" & sonSatir).Interior.ColorIndex = xlNone

    ' Renkleri uygula
    For i = LBound(renkAralik) To UBound(renkAralik)
        If renkAralik(i) <> -1 Then
            Sh.Range("A" & i + 1 & ":Q" & i + 1).Interior.Color = renkAralik(i)
        End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Bu kodum var modül olarak
 
Merhaba,
  1. Belirttiğiniz alanı seçiniz
  2. Koşullu Biçimlendirme
  3. Yeni Kural
  4. Biçimlendirilecek hücreleri belirlemek için formül kullan
  5. Formul : SATIR()=HÜCRE("Sat")
  6. Biçimlendirmeyi yapınız
  7. Tamam
ilgili sayfanın kod bölümüne
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Calculate
End Sub

işlem tamamdır.
 
Edit:
KoşB harici AI ürünü bir kod;

Sayfa kaynağına ekleyiniz.
C++: 
Dim oncekiSatir As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim aktifSatir As Range
    Dim alan As Range

    ' Sadece A1:M27 aralığında işlem yap
    Set alan = Me.Range("A1:M27")
  
    If Not Intersect(Target, alan) Is Nothing Then
        If Not oncekiSatir Is Nothing Then
            oncekiSatir.Interior.ColorIndex = xlNone
        End If

        Set aktifSatir = Intersect(alan, Me.Rows(Target.Row))

        If Not aktifSatir Is Nothing Then
            aktifSatir.Interior.ColorIndex = 6
            Set oncekiSatir = aktifSatir
        End If
    End If
End Sub

258294
 
poetika' Alıntı:
Kod: 
Sub GenelListeyiRenklendir_HIZLI()
    Dim Sh As Worksheet
    Set Sh = ThisWorkbook.Sheets("Genel Liste")

    Dim sonSatir As Long
    sonSatir = Sh.Cells(Sh.Rows.Count, "Q").End(xlUp).Row
    If sonSatir < 2 Then Exit Sub

    Dim veriAralik As Variant
    Dim renkAralik() As Long
    Dim i As Long
    Dim durum As String

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' Q sütunundaki verileri al
    veriAralik = Sh.Range("Q2:Q" & sonSatir).Value
    ReDim renkAralik(1 To UBound(veriAralik, 1))

    ' Renkleri belirle
    For i = 1 To UBound(veriAralik, 1)
        durum = Trim(veriAralik(i, 1))

        Select Case durum
            Case "DOSYA BİRLEŞTİRİLDİ", "TAKİP ÖNCESİ TAHSİL EDİLDİ", "İCRA YOLUYLA TAHSİL EDİLDİ", _
                 "İPTAL EDİLDİ", "MÜKERRER SATIR", "TAHSİL EDİLDİ", "TERKİN EDİLDİ (PARASAL SINIR ALTI)", "TERKİN EDİLDİ (VEFAT)", "TERKİN EDİLDİ (MAHKEME KARARI)"
                renkAralik(i) = RGB(198, 239, 206) ' yeşil

            Case "DOSYA BULUNAMADI", "İCRAYA GÖNDERİLDİ", "SORUNLU İNCELENİYOR"
                renkAralik(i) = RGB(255, 220, 225) ' turuncu

            Case "İADE OLDU", "MERNİS ADRESİ BULUNAMADI"
                renkAralik(i) = RGB(255, 242, 204) ' altın

            Case "TAKSİTLENDİRME YAPILDI"
                renkAralik(i) = RGB(221, 235, 247) ' mavi

            Case Else
                renkAralik(i) = -1 ' renksiz bırak
        End Select
    Next i

    ' Önce tüm renkleri temizle
    Sh.Range("A2:Q" & sonSatir).Interior.ColorIndex = xlNone

    ' Renkleri uygula
    For i = LBound(renkAralik) To UBound(renkAralik)
        If renkAralik(i) <> -1 Then
            Sh.Range("A" & i + 1 & ":Q" & i + 1).Interior.Color = renkAralik(i)
        End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Bu kodum var modül olarak
Genişletmek için tıkla ...


Bu kodun duracak verdiğim kodu ilgili sayfanın sekmesine (Genel Liste) sağ tuş ile tıklayıp kod görüntüle dedikten sonra aşağıda gösterdiğim kısıma yapıştıracaksınız.

258301
 
Ofis 365 te bu özellik yerleşik olarak var.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst