• DİKKAT

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

excel sayfada çalışırken aktif satırın renginin değişmesi

A

a_self_lion

Katılım
14 Ocak 2005
Mesajlar
807
Excel Vers. ve Dili
Microsoft Office Professional Plus 2021
Selam arkadaşalar önümde 1000 1500 satırlık bir tablo var buralarda ben satır satır a stunundunda malzeme adına göre k sutununa bilgi girişi yapıyorum. Burda hep satırlar beyaz olduğundan ve hepsi aynı olduğundan göz kayması yaşıyorum. Bunun önüne geçebilmem için tam veri girişi yapacağım aktif satırımı rengini örneğin sarı yeşil felan olmasını sağlayabilirmiyim. Aşağı ok tuşuna basınca bir altındaki satırın rengi değişsin. Ve ctr F ile bulduğum satırın rengi değişsin inş. anlatabilmişimdir.
 
Merhaba,

Aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayıp deneyiniz.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Son
Dim i           As Long
Dim SonKolon    As Integer
Dim Secim       As Range
Set Secim = Range("A1").CurrentRegion
SonKolon = Secim.Columns.Count
Cells.Interior.ColorIndex = xlNone
If Target.Row = 1 Then Exit Sub
Range(Cells(Target.Row, "A"), Cells(Target.Row, SonKolon)).Interior.ColorIndex = 44
Son:
End Sub
 
Necdet HOcam süpersiniz kodlara baktım inceledim işim gördü fakat neden sadece H sutunuda kadar geliyor m sutununa kadar getiremezmiyiz.
 
Merhaba,

sütun sayısının değişken olmasını istedim.

siz sabit sütun seçsin isterseniz SonKolon değişkenine istediğiniz değeri verebilirsiniz. M sütununa kadar olmasını isterseniz 13 değerini kullanmalısınız.
 
Bir de Necdet Hocam elineze sağlık tekrardan burda listede işlem yaparken girişleri felan yapıyorum alt satır aüst satıra çıkınca inince istediğim gibi sarı bir renkle gösteriyor satırı çokgüzel Fakat küçük bir sorun makro çalıştığı için geri al çalışmıyor sebebi ne olabilir. Bu durumu nasıl düzeltebilirim. Bazen çok lazım oluyor.
 
Merhaba,

Maalesef bu konuyu bilmiyormu, umarım bir çözümü vardır.
 
Selam arkadaşlar Sayın Necdet beyin verdiği bu kodla
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Son
Dim i As Long
Dim SonKolon As Integer
Dim Secim As Range
Set Secim = Range("A1").CurrentRegion
SonKolon = Secim.Columns.Count
Cells.Interior.ColorIndex = xlNone
If Target.Row = 1 Then Exit Sub
Range(Cells(Target.Row, "A"), Cells(Target.Row, SonKolon)).Interior.ColorIndex = 44
Son:
End Sub
Genişletmek için tıkla ...
aktif satırı renklendirebiliyorum ve kontrolümü daha sağlıklı yapabiliyorum. Benim istediğim iki işlem daha yaptırabilirmiyiz.
1- Aktif satırı renklendirirken örnek sarı diyelim h sutununa denk gelen yeri h4 diyelim kırmızı J Stununu mavi olacak şekilde yapabilirmiyiz.
2- Diyelim ki aktif sutun üstüne gelemden önce kırmızı renkte olsun sonra biz üzerine geldiğimiz zaman komple sarı oldu h sutununa denk gelen kırmızı j stununa denk gelen yeri mavi oldu biz üzerinden ayrılınca yine komple kırmızı kalabilir mi?
Şimdiden ilgilenen arkadaşlara teşekkür ederim.
 
Selamlar,

Ekteki örnek dosyada 3 farklı satır-sütun renklendirme örnekleri bulunmaktadır. Özellikle ilk sayfadaki uygulamada seçimler renksizdir fakat geri al özelliği çalışmaktadır. Dilerseniz alternatif olarak kullanabilirsiniz.
 

Ekli dosyalar

Korhan bey çalışmanıza baktım çok güzel elinize sağlık çokda güzel olmuş özelliklede şu sayfa1 de olan. Birde keşke buna h sutnunda keşişen ve j stununda keşien hücre farklı olabilseydi tatından yenmezdi vallahi. :))
 
Selamlar,

Ekteki örnek dosyayı incelermisiniz. Koşullu biçimlendirme ile hazırlanmıştır. Kod çalışırken sayfadaki tüm koşullu biçimlendirmeler silinmektedir. Bu sebeple kullandığınız sayfanızda kendi koşullu biçimlendirmeleriniz varsa örnek dosyayı kullanmayınız.

Uygulanan kod; (Sayfanın kod bölümüne uygulayın.)

Kod: 
Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ADRES As String, KARAKTER As Variant, X As Integer
    Dim Y As Byte, İLK As Integer, SON As Integer
    Dim YENİ_ADRES_H As String, YENİ_ADRES_J As String
 
    KARAKTER = Array("$", ":", ",", 1, 2, 3, 4, 5, 6, 7, 8, 9, 0)
 
    On Error Resume Next
    Cells.FormatConditions.Delete
    On Error GoTo 0
 
    Target.EntireRow.FormatConditions.Add Type:=xlExpression, Formula1:="1"
    Target.EntireRow.FormatConditions(1).Interior.ColorIndex = 6
    ADRES = Selection.Address(1, 0)
    If InStr(1, ADRES, ":") > 0 Then
        YENİ_ADRES_H = ADRES
        İLK = 1
        For X = 1 To Len(ADRES)
            For Y = 0 To UBound(KARAKTER)
            If Mid(ADRES, X, 1) = KARAKTER(Y) Then
                If İLK = Empty Then
                    İLK = X + 1
                Else
                    SON = X - İLK
                End If
                If SON > 0 Then Exit For
            End If
            Next
            If SON <> Empty Then
                YENİ_ADRES_H = WorksheetFunction.Replace(YENİ_ADRES_H, İLK, SON, "H")
                İLK = Empty: SON = Empty
            End If
        Next
 
        YENİ_ADRES_J = ADRES
        İLK = 1
        For X = 1 To Len(ADRES)
            For Y = 0 To UBound(KARAKTER)
            If Mid(ADRES, X, 1) = KARAKTER(Y) Then
                If İLK = Empty Then
                    İLK = X + 1
                Else
                    SON = X - İLK
                End If
                If SON > 0 Then Exit For
            End If
            Next
            If SON <> Empty Then
                YENİ_ADRES_J = WorksheetFunction.Replace(YENİ_ADRES_J, İLK, SON, "J")
                İLK = Empty: SON = Empty
            End If
        Next
 
        Range(YENİ_ADRES_H).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_H).FormatConditions(1).Interior.ColorIndex = 3
        Range(YENİ_ADRES_J).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_J).FormatConditions(1).Interior.ColorIndex = 8
 
    Else
 
        Cells(Target.Row, "H").FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Cells(Target.Row, "H").FormatConditions(1).Interior.ColorIndex = 3
        Cells(Target.Row, "J").FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Cells(Target.Row, "J").FormatConditions(1).Interior.ColorIndex = 8
    End If
End Sub
 

Ekli dosyalar

Selamlar,

Üstteki mesajımdaki kod yerine alternatif olarak aşağıdaki daha kısa olan kodu kullanabilirsiniz. Ben döngü ile işlemi gereksiz yere biraz uzun tutmuştum.

Kod: 
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ADRES As String, NESNE As Object, X As Integer
    Dim YENİ_ADRES_H As String, YENİ_ADRES_J As String
    
    Set NESNE = CreateObject("VBScript.Regexp")
    NESNE.Pattern = "[^0-9\,\:\$]"
    NESNE.Global = True
    
    On Error Resume Next
    Cells.FormatConditions.Delete
    On Error GoTo 0
    
    Target.EntireRow.FormatConditions.Add Type:=xlExpression, Formula1:="1"
    Target.EntireRow.FormatConditions(1).Interior.ColorIndex = 6
    
    ADRES = Selection.Address
    If InStr(1, ADRES, ":") > 0 Then
        YENİ_ADRES_H = NESNE.Replace(ADRES, "H")
        YENİ_ADRES_J = NESNE.Replace(ADRES, "J")
        Range(YENİ_ADRES_H).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_H).FormatConditions(1).Interior.ColorIndex = 3
        Range(YENİ_ADRES_J).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_J).FormatConditions(1).Interior.ColorIndex = 8
        Set NESNE = Nothing
        
    Else
    
        Cells(Target.Row, "H").FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Cells(Target.Row, "H").FormatConditions(1).Interior.ColorIndex = 3
        Cells(Target.Row, "J").FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Cells(Target.Row, "J").FormatConditions(1).Interior.ColorIndex = 8
    End If
End Sub
 
inceledim Korhan bey Elinize sağlık fakat H sutununa denk gelen ve J sutununa denk gelen yer farklı renklerde olmuyor benim tek istediğim şu anda o aslında. Birde yapılabilirse tabi Geri al seçeneğinin aktif olması. Eski renk şu anda korunuyor. Orası çok güzel.
 
Selamlar,

#10 nolu mesajımdaki dosyada seçim yaptığınızda H ve J sütunlarındaki hücreler farklı renk olmuyor mu?
 
hem örnek dosyada hemde benim dosyama uyguladığımda olmuyor malesef.
birde bu kodun sadece c10 ile ac100 arasında çalışması sağlanabilir mi?
 
Son düzenleme:
Selamlar,

Peki seçim işlemini nasıl yapıyorsunuz?
 
Seçim işlemi derken normal olarak aşağı yukarı ok tuşları ile veya mause ile c10 ile ac100 arasındaki satırlardan birini seçiyorum. bir önceki mesajımda da düzelttiğim gibi c10 ile ac100 araında çalışmasını sağlayabilirsek daha güzel olucak.
 
Selamlar,

İlginç bir durum bende çalışıyor.

XIFI.jpg
 
Selamlar,

Özelden yazdığınız mesajlar sonucunda sorunu çözdük.

Sorun sizin 2007 versiyonu kullanmanızdan kaynaklanıyor. Ben 2003 versiyonda denemeler yaptığım için sorunu tesbit edememiştim. 2007 versiyonda makro kaydet ile bir hücreye koşullu biçimlendirme uyguladığımızda aşağıdaki satır ekstradan oluşmaktadır.

Kod: 
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

Ve bu satır benim önerdiğim kod içinde olmadığı için siz olumlu sonuç alamadınız.


Önerdiğim kodu aşağıdaki şekilde değiştirip denerseniz olumlu sonuç alabilirsiniz.


Kod: 
Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ADRES As String, NESNE As Object, X As Integer
    Dim YENİ_ADRES_H As String, YENİ_ADRES_J As String
 
    On Error Resume Next
    Cells.FormatConditions.Delete
 
    If Intersect(Target, Range("C10:AC100")) Is Nothing Then Exit Sub
 
    Target.EntireRow.FormatConditions.Add Type:=xlExpression, Formula1:="1"
    Target.EntireRow.FormatConditions(1).Interior.ColorIndex = 6
 
    ADRES = Selection.Address
 
    If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(ADRES, 2, 1)) = 0 Then
        Set NESNE = CreateObject("VBScript.Regexp")
        NESNE.Pattern = "[^0-9\,\:]"
        NESNE.Global = True
 
        YENİ_ADRES_H = NESNE.Replace(ADRES, "$H")
        YENİ_ADRES_J = NESNE.Replace(ADRES, "$J")
        Range(YENİ_ADRES_H).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_H).FormatConditions(Range(YENİ_ADRES_H).FormatConditions.Count).SetFirstPriority
        Range(YENİ_ADRES_H).FormatConditions(1).Interior.ColorIndex = 3
        Range(YENİ_ADRES_J).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_J).FormatConditions(Range(YENİ_ADRES_J).FormatConditions.Count).SetFirstPriority
        Range(YENİ_ADRES_J).FormatConditions(1).Interior.ColorIndex = 8
        Set NESNE = Nothing
 
    ElseIf InStr(1, ADRES, ":") > 0 Then
        Set NESNE = CreateObject("VBScript.Regexp")
        NESNE.Pattern = "[^0-9\,\:\$]"
        NESNE.Global = True
 
        YENİ_ADRES_H = NESNE.Replace(ADRES, "H")
        YENİ_ADRES_J = NESNE.Replace(ADRES, "J")
        Range(YENİ_ADRES_H).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_H).FormatConditions(Range(YENİ_ADRES_H).FormatConditions.Count).SetFirstPriority
        Range(YENİ_ADRES_H).FormatConditions(1).Interior.ColorIndex = 3
        Range(YENİ_ADRES_J).FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Range(YENİ_ADRES_J).FormatConditions(Range(YENİ_ADRES_J).FormatConditions.Count).SetFirstPriority
        Range(YENİ_ADRES_J).FormatConditions(1).Interior.ColorIndex = 8
        Set NESNE = Nothing
 
    Else
 
        Cells(Target.Row, "H").FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Cells(Target.Row, "H").FormatConditions(Cells(Target.Row, "H").FormatConditions.Count).SetFirstPriority
        Cells(Target.Row, "H").FormatConditions(1).Interior.ColorIndex = 3
        Cells(Target.Row, "J").FormatConditions.Add Type:=xlExpression, Formula1:="1"
        Cells(Target.Row, "J").FormatConditions(Cells(Target.Row, "J").FormatConditions.Count).SetFirstPriority
        Cells(Target.Row, "J").FormatConditions(1).Interior.ColorIndex = 8
    End If
End Sub
 

Ekli dosyalar

Sayın Korhan bey benim sorunum sizinde tespinizle 2007 sürümü olmasından kaynaklanıyormuş. TeamViever la bağlanıp sorunumu hallettiğiniz için size ayriyeten müteşekkirim.
 
Selamlar,

#18 nolu mesajımdaki koda küçük bir ekleme yaptım. Lütfen son halini kullanınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst