• DİKKAT

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

Renkli Hücreleri Bulma ve Liste Şeklinde Sıralama

C

ceylankral

Katılım
19 Temmuz 2010
Mesajlar
53
Excel Vers. ve Dili
2007
Merhaba arkadaşlar. Bir konuda yardıma ihtiyacım var.

Elimde sipariş listesi var.

http://www.dosya.tc/server6/8lg2ad/1.xls.html

Bu sipariş listesinde bazı günlere ait siparişlerim var. Bu siparişlere atadığım renklerin anlamları var.

siyah olan - yeni alınan iş
turuncu olan - hazır ama ücreti ödenmeyen ve teslim etmediğimiz iş
kırmızı olan - bugün hazır olacak iş
yeşil olan - müşteriye teslim edilen iş

Benim isteğim; turuncu , kırmızı ve siyah yazı rengine sahip olan işleri liste şeklinde alt alta sıralamak. sıralama yapılırken de turuncular en üstte, sonra kırmızı sonra da siyah şekilde düzenlensin.

verdiğim çalışmada sayfalarımdan sadece bir kısmını gösterdim. bu örnekteki gibi aylarca oluşturulmuş listem var. yani renk taraması yaparken excel dosyamın içindeki bütün herşeyi tarayacak ve o renktekileri listeleyecek.

Oluşturulacak olan liste 25-30 u geçmez zaten. ama tarama yapacağı alan biraz fazla geniş.

Son olarak, bu liste farklı bir excel dosyasına aktarılacak. Yani siparişlerin olduğu dosyaya listelenmeyecek.

Bu mümkün mü acaba?
 
Merhaba.
Alt taraftan sayfa adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçtiğinizde açılan ekranın
sağ tarafındaki boş alana aşağıdaki kod'u yapıştırın.

Yeni belgeye değil Sayfa2'ye listeler.

Yeşil için sıra belirtmediğinizden en sona alınıyor.
.
Kod: 
[SIZE="2"][FONT="Trebuchet MS"][COLOR="Blue"][B]Sub RENK_GRUPLANDIR_BRN()[/B][/COLOR]
Dim s1, s2 As Worksheet: Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
s2.Cells.ClearContents
s2.Cells(1, 1) = "TARİH": s2.Cells(1, 2) = "SİPARİŞ"
For sütun = 1 To s1.[IV1].End(1).Column
    For satır = 2 To s1.Cells(65536, sütun).End(3).Row
        If s1.Cells(satır, sütun).Font.Color <> 4626167 Then GoTo 10
            sat = s2.Cells(65536, 1).End(3).Row + 1
            s2.Cells(sat, 1) = s1.Cells(1, sütun)
            s2.Cells(sat, 2) = s1.Cells(satır, sütun)
            s2.Range(s2.Cells(sat, 1), s2.Cells(sat, 2)).Font.Color = 4626167
10: Next
Next
For sütun = 1 To s1.[IV1].End(1).Column
    For satır = 2 To s1.Cells(65536, sütun).End(3).Row
        If s1.Cells(satır, sütun).Font.Color <> 255 Then GoTo 20
            sat = s2.Cells(65536, 1).End(3).Row + 1
            s2.Cells(sat, 1) = s1.Cells(1, sütun)
            s2.Cells(sat, 2) = s1.Cells(satır, sütun)
            s2.Range(s2.Cells(sat, 1), s2.Cells(sat, 2)).Font.Color = 255
20: Next
Next
For sütun = 1 To s1.[IV1].End(1).Column
    For satır = 2 To s1.Cells(65536, sütun).End(3).Row
        If s1.Cells(satır, sütun).Font.Color <> 0 Then GoTo 30
            sat = s2.Cells(65536, 1).End(3).Row + 1
            s2.Cells(sat, 1) = s1.Cells(1, sütun)
            s2.Cells(sat, 2) = s1.Cells(satır, sütun)
            s2.Range(s2.Cells(sat, 1), s2.Cells(sat, 2)).Font.Color = 0
30: Next
Next
MsgBox "RENK SIRALAMASI BİTTİ"
s2.Range("A:A").NumberFormat = "m/d/yyyy"
s2.Activate: s2.Columns.AutoFit
[B][COLOR="blue"]End Sub[/COLOR][/B][/FONT][/SIZE]
 
Son düzenleme:
Ömer Baran ve muygun kardeşilerim Allah razı olsun. İstediğim gibi yapmışsınız ikinize de teşekkürler. Ama pratiklik açısından Ömer Baran ustamın yaptığı daha uygun gibi. Çünkü buton kullanmadan anlık değişiklik istiyoruz.

Ömer Baran ustam, tekrar teşekkür ederim. Birkaç ufak isteğim daha olacak. Kodlarınız harika çalışıyor. Bu listelemeyi, istediğim renkleri sadece altalta olacak şekilde düzenleyebilir miyiz?
Yani gün gün değil de A sütununa altalta hepsini sıralasa? Ve yeşil renkli olanları listeye hiç almasa? Bunlarda olduğu an işlem tamamdır. Tekrar çook teşekkürler.
 
Sayın muygun'un cevabı bu istediğinizi yapmıyor mu zaten?

Verdiğim kod cevabına tekrar bakınız, oradaki kod'u güncelledim.

Sanırım istediğiniz budur.
 
yapıyor evet ama butonla işlem yapıldığı için uygun olmuyor.

kodunuz mükemmel çalışıyor. ama ben salaklık ettim bir durumu daha söylemeyi unuttum. Aşağıdaki sayfalarda OCAK ŞUBAT MART diye 12 ayında isimlerinin olduğu 12 sayfa mevcut. her bir ayın siparişleri o ayın sayfasında. 13. sayfaya sizin kodu yapıştırdığımda haliyle hata verdi. Son olarak bunu nasıl halledebiliriz. çok özür dilerim sizi yordum.
 
Yazdığım cevapların altında yer alan açıklamayı okuyarak örnek belgenizi yenilerseniz,
ben veya başka bir üye çözüm üretecektir.
Örnek belgenin çok fazla satırlı olması gerekmez elbette.
Sayfa isimlerini filan görmek lazım neticede.

Önceliğin neyde olmasını istediğiniz belli değil.
--Ocak ayının renk sıralaması sonra şubat ayının renk sıralaması mı?
--Yoksa önce tüm ayların turuncuları, ardından tüm ayların kırmızıları mı?
 
Siparişler dosyasının bir kısmının üzerinde uğraştığım için genelini hesaba katmamışım.Ama ne deseniz haklısınız tekrar özür dilerim.

dosya birebir aşağıdaki gibidir. sadece siparişleri rastgele günlere sıraladım.(Normalde bütün günlerde siparişler yazılıdır.)

http://s8.dosya.tc/server/fw5bhs/siparis-ceylankral.xls.html

13. sayfada yada başka bir excel sayfasında;

1- Önce bütün aylardaki turuncu renkliler altalta
2- Daha sonra bütün aylardaki kırmızı renkliler turuncuların altına devam edecek
3- Son olarak bütün aylardaki siyah renkliler de kırmızıların altında devam edecek.

Yeşil renkliler listeye girmeyecek.

İlginize çok teşekkür ederim. Allah razı olsun.
 
Merhaba
Profilinizde ms 2007 excel görünüyor, eğer kullandığınız da öyle ise; 2007 den itibaren
excelde font rengi ve dolgu rengine görede sıralama mümkün
2007 ve üstü versiyonlar için aşağıdaki gibi olabilir.
http://s6.dosya.tc/server5/36wfb2/siparis-ceylankral1.zip.html
Sayfaları renklere göre sıralayıp turuncu,kırmızı ve siyah olanları yeni oluşturacağı "Sonuç"
adlı dosyaya aktaracaktır.
Kod: 
 Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Dim k As Workbook
Dim a, b, c, d, s
Set k = Application.Workbooks.Add
Application.DisplayAlerts = False
k.SaveAs Filename:=ThisWorkbook.Path & "\" & "SONUÇ", FileFormat:=ThisWorkbook.FileFormat
Application.DisplayAlerts = True
ThisWorkbook.Activate
Application.ScreenUpdating = False
For a = 1 To Sheets.Count
Set s1 = ActiveWorkbook.Sheets(a)
For b = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
 ActiveWorkbook.Worksheets(a).Sort.SortFields.Clear
c = s1.Cells(Rows.Count, b).End(3).Row
  With s1.Sort.SortFields
    .Add(s1.Range(s1.Cells(2, b), s1.Cells(c, b)), xlSortOnFontColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(247, 150, 70)
    .Add(s1.Range(s1.Cells(2, b), s1.Cells(c, b)), xlSortOnFontColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)
    .Add(s1.Range(s1.Cells(2, b), s1.Cells(c, b)), xlSortOnFontColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 0, 0)
    .Add(s1.Range(s1.Cells(2, b), s1.Cells(c, b)), xlSortOnFontColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(0, 176, 80)
    End With
    With Worksheets(a).Sort
        .SetRange s1.Range(s1.Cells(1, b), s1.Cells(c, b))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    If c <> 1 Then
    For d = 2 To c
   If s1.Cells(d, b) <> "" Then
   If s1.Cells(d, b).Font.Color = RGB(0, 176, 80) Then Exit For
   If s1.Cells(d, b).Font.Color = RGB(247, 150, 70) Or s1.Cells(d, b).Font.Color = RGB(255, 0, 0) Or s1.Cells(d, b).Font.Color = RGB(0, 0, 0) Then
   s = s + 1
      k.Sheets(1).Cells(s, 1) = CDate(s1.Cells(1, b).Value)
      k.Sheets(1).Cells(s, 2) = s1.Cells(d, b).Value
      k.Sheets(1).Cells(s, 2).Font.Color = s1.Cells(d, b).Font.Color
    End If: End If: Next
      End If: Next: Next
    Application.ScreenUpdating = False
    k.Activate
    k.Sheets(1).Columns("A:A").ColumnWidth = 11
    ActiveWorkbook.Save
End Sub
 
Ömer BARAN kardeşim, işlem tamamdır. Allah senden razı olsun. Harika bir şekilde çalışıyor. Tam da istediğim gibi.

geriye küçük bir şey kaldı. o da hazırladığınız makroyu orijinal Siparişler sayfama aktarmak. 13. sayfanın içeriğini kopyalayıp, orijinal dosyaya yapıştırdığımda hata veriyor. Nasıl kopyalayabilirim?

PLİNT kardeşime de çok teşekkürler.
 
Gerçek belgenize 13. sayfa olarak TÜM adını taşıyan bir sayfa ekleyin ya da 13. sayfanın adını KOD'un başında Sheets("TÜM") kısmındaki TÜM yerine yazarak deneyin.
Ya da veri azaltarak gerçek belgenizin bir örneğini foruma ekleyin.
 
Harikasınız. İşte budur :) Çok faydalı oldu firmamız için. Allah razı olsun. Herşey gönlünüzce olsun :)
 
bir sorun oldu yine :)

orijinal dosyaya dediğiniz gibi kopyaladım. sayfayı kapatmadan çalıştırdığımda sorun görünmedi. ama sayfayı kaydedip kapatıp açtığımda aşağıdaki hatayı veriyor;

344w1o2.jpg



Devam butonuna basıp , RENK GRUPLANDIR butonuna bastığımda ;

oaoxg7.jpg


bu hatayı verdi.

Orijinal dosyamın adı Siparişler - 2016.xlsx

sorun nerden kaynaklanıyor acaba?
 
Son düzenleme:
Merhaba.

E-posta gönderdim, posta kutusunu kontrol edin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst