Soru Birden Fazla Sütunda En yüksek 10 değeri filtrelemek

[dengeceteris]

Merhabalar.. filtreleme ile ilgili bir sorum olacak. C sütunundan başlayıp CW sütununa kadar giden satır olarak ise 1000 satırlık verim var. (C7:CW1000) Yapmak istediğim ise aslında gelişmiş bir filtreleme benzeri bir şey yapabilmek sonrasında. Amacım ise mesela C sütununda en yüksek ilk 10 değeri D sürununda en yüksek ilk 10 değeri bulup bunu yeşil renk yapmak. En düşük 10 değeri bulup kırmızı vb yapmak arada kalanları ise örneğin açık mavi yapmak. Sonrasında bu renklere göre bütün sütunları filtreleme yapabilmek. Bunu koşullu biçimlendirme ile yapıyorum ama aynı anda gelişmiş filtreleme gibi bir uygulamaya çeviremiyorum. Birde filtreleme yapmak istediğim sayfayı makro ile başka sayfadan getirdiğim için veriyi çekince zaten koşullu biçimlendirmeleri sıfırlıyor. Bunu yapmak mümkün müdür acaba ?

Yardımlarınız için şimdiden tşk ederim.

 

[MusaPEKEL]

Sub RenklendirVeFiltrele()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim topValuesCount As Long
    
    ' Çalışma sayfasını belirle (örneğin, "Sheet1" olarak adlandırılmış bir sayfa)
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Veri aralığını belirle (C7:CW1000 aralığı)
    Set rng = ws.Range("C7:CW1000")
    
    ' Veri aralığındaki son satır ve sütunları bul
    lastRow = rng.Rows.Count + rng.Row - 1
    lastCol = rng.Columns.Count + rng.Column - 1
    
    ' En yüksek ve en düşük değerleri bul
    topValuesCount = 10 ' İlk 10 değeri seç
    
    ' Her bir sütun için en yüksek ve en düşük değerleri bul ve renklendir
    For j = rng.Column To lastCol
        ' En yüksek 10 değeri yeşil renge boyayın
        For i = 1 To topValuesCount
            ws.Cells(Application.WorksheetFunction.Match(Application.WorksheetFunction.Large(rng.Columns(j), i), rng.Columns(j), 0) + 6, j).Interior.Color = RGB(0, 255, 0)
        Next i
        ' En düşük 10 değeri kırmızı renge boyayın
        For i = 1 To topValuesCount
            ws.Cells(Application.WorksheetFunction.Match(Application.WorksheetFunction.Small(rng.Columns(j), i), rng.Columns(j), 0) + 6, j).Interior.Color = RGB(255, 0, 0)
        Next i
    Next j
    
    ' Filtreleme yapmak için veri aralığını belirle
    Set rng = ws.Range("C6:CW" & lastRow)
    
    ' Filtreleme yap
    rng.AutoFilter
End Sub

 

[dengeceteris]

Musa bey günaydın. Öncelikle ilginiz için size minnettarım. Formülünüzü uyguladım. Yeşil ve kırmızı olarak renklendirdiği alanlar oldu ama doğru rakamları getirmedi. Mesela enyüksek olan 10 tanesi değilde aralardan karışık yeşiller yaptı. Kırmızı olanlar içinde aynısını yaptı. Birde belki devam etseydi hesaplamaya doğru sonucu verebilirdi. Ama aşağıda yazdığım yerde takıldı yani çalıştırınca makroyu burada debug veriyor.

ws.Cells(Application.WorksheetFunction.Match(Application.WorksheetFunction.Large(rng.Columns(j), i), rng.Columns(j), 0) + 6, j).Interior.Color = RGB(0, 255, 0)

 

[dengeceteris]

Tekrar merhabalar.. Bu formül üzerinde revize yapma imkanı olur mu acaba

 

[dengeceteris]

Umarım biri ilgilenir

 

[excelokyanus500]

Deneyin.

Sub MinMaxIlk10()
    Dim ws As Worksheet
    Dim rng As Range
    Dim col As Range
    Dim cell As Range
    

    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set rngBig = ws.Range("C7:Cw1000") ' Kendinize uyarlayın
      ws.AutoFilterMode = False
     Cells.ClearFormats
    
    
    For Each col In rngBig.Columns
    
        enKucuk = 0
        enYuksek = 0
        
        
        If WorksheetFunction.CountA(col) > 0 Then
          
            enKucuk = Application.WorksheetFunction.Min(col)
            enYuksek = Application.WorksheetFunction.Max(col)
    
        
        
      
        For Each cellBig In col
        
            If Not IsEmpty(cellBig.Value) Then
                
                cellBig.Select
                    Set rng = Selection
    
    ' En küçük 10 değeri renklendir
    For i = 1 To 10
        ' En küçük değeri bul
        enKucuk = Application.WorksheetFunction.Small(rng, i)
        
        ' Belirtilen değeri içeren hücreleri bul ve renklendir
        For Each cell In rng
            If cell.Value = enKucuk Then
                renk = RGB(0, 255, 0) ' Yeşil
                cell.Interior.Color = renk
            End If
        Next cell
    Next i
       End If
    ' En yüksek 10 değeri renklendir
    For i = 1 To 10
        ' En yüksek değeri bul
        enYuksek = Application.WorksheetFunction.Large(rng, i)
        
        ' Belirtilen değeri içeren hücreleri bul ve renklendir
        For Each cell In rng
            If cell.Value = enYuksek Then
                renk = RGB(255, 0, 0) ' Kırmızı
                cell.Interior.Color = renk
            End If
        Next cell
    Next i
            
        Next
        End If ' Kolon küçük ve büyük kontrol sonu
    Next
 
 
    Columns("C:CW").AutoFilter
    Range("C1").Select
End Sub

 

[excelokyanus500]

Bulunanları ayrı sayfada görmek isterseniz bu makroyu da deneyin.

Sub RenkliHucreleriTespitEtVeKopyala3()
    Dim ws As Worksheet
    Dim wsTespitler As Worksheet
    Dim rngSutun As Range
    Dim cell As Range
    Dim renk As Long
    Dim tespitlerSatir As Long
    Dim sütunIndex As Integer


    Set ws = ThisWorkbook.Sheets("Sheet1") ' Sayfa adını uygun şekilde değiştirin
    Set rngSutun = ws.Range("C7:Cw1000") ' Sütun belirleyin
    
   On Error Resume Next
    Set wsTespitler = ThisWorkbook.Sheets("Tespitler")
    On Error GoTo 0

    ' Eğer Tespitler sayfası varsa sil
    If Not wsTespitler Is Nothing Then
        Application.DisplayAlerts = False
        wsTespitler.Delete
        Application.DisplayAlerts = True
    End If
    ' Yeni Tespitler sayfası oluştur
    Set wsTespitler = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsTespitler.Name = "Tespitler"
    ' "Tespitler" sayfasındaki son kullanılan satırı bul
    tespitlerSatir = wsTespitler.Cells(wsTespitler.Rows.Count, "A").End(xlUp).Row + 1
    
    ' Renkli hücreleri tespit et ve "Tespitler" sayfasına kopyala
    For Each sütun In rngSutun.Columns
        sütunIndex = sütun.Column
        For Each cell In sütun.Cells
            If cell.Interior.ColorIndex <> xlNone Then ' Hücre renkli mi kontrolü
            
                wsTespitler.Cells(tespitlerSatir, sütunIndex).Value = cell.Value
                tespitlerSatir = tespitlerSatir + 1
            End If
        Next cell
    Next sütun
    


    ' Silme ve taşıma işlemini gerçekleştirilecek sütunları belirle (C ile CW arasındaki sütunlar)
    Set rng = wsTespitler.Range("C:CW")

    ' Boş hücreleri sil ve dolu hücreleri yukarı taşı
    rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    
    MsgBox "Renkli hücreler başarıyla tespit edildi ve Tespitler sayfasına kopyalandı.", vbInformation
End Sub

 

[dengeceteris]

Hocam ilginiz için tşk ederim. Karşılaştığım sonucu yazayım. Şimdi aynı sayfadaki işlem kodunda ilk 10 değeri doğru buluyor ama rengi yeşil değilde kırmızı yapıyor muhtemelen renk değişimi yapmak gerekiyor. Ama en düşük 10 değerde sadece -1 olanları işaretliyor. birincisi renklerin yerlerinin değişimi ve en düşük değerleri bulurken sadece -1 olan değil o sütunun en düşük 10 değerini almaya çalışıyorum.

İkincisi ise excelde böyle bir özellik var mıdır bilmiyorum ama mesela sadece yeşil olan yani en yüksek değerleri filtreleme imkanı olur mu. Mesela gelişmiş filtrelemede sütunlara belli bir rakamın üstü eşiti yada düşüğü gibi veriyorum buluyor ama renk için böyle bir özellik varmıdır bilemedim.

 

[dengeceteris]

Herkese selamlar…
Bir konuda acizane öneri iletmek istiyorum. Bu siteye ne zaman bir soru yönlettiysem kahir ekseriyetinde sorularımın cevaplarını aldım veya çok zaman soru yöneltmediğin zamanlar ise yaşadığım problemlere çözümü yine sitede aradım ve çok zaman buldum yani hem vazgeçilmezim hem güvencem. Burada olağan üstü çabayı görebiliyorum ve emeği geçenlere çok tşk ediyorum. Ama bazen şöyle sorunlar oluyor destek ekibinden değil ama bu altın üye olabilir veya harici bir kişi bildikleri bir konuda onlarda yardımcı oluyor veya olmaya çalışıyor. Ama önerilen bir formülde yada vba da eksiklik olduğu zaman bir daha geri dönüş sağlanmıyor bunu uyguladım ama şöyle böyle hata aldım böyle bir sonuç oldu gibi yazsakta bu havada kalıyor. Ben buranın işleyini net olarak bilmiyorum ama her uzman arkadaşta her herhalde her mesaja vakit bulupta tek tek bakmıyordur. Belkide karşılıklı cevaplar oluşunca herhalde birileri cevap yazıyordur diye bakmıyorlardır. Tabiki bu benim tahminim yanılıyor olabilirim. Ama en azından bir arkadaş yardımcı olmak adına yazdığı zaman geri dönüşleride beslerse herhalde daha faydalı olur diye düşünüyorum. Meramımı anlatırken umarım yanlış anlaşılmalara sebebiyet verecek anlam karmaşası oluşmamıştır. Saygılarımla