Renklere karşılık gelen değerleri bulmayı sağlayan makro

[ozijikanu]

Merhaba,
Ekteki dosyada, her satır için sarı renk ile belirtilen hücreye karşılık gelen tarih değerini ayrı bir listede buldurmak istiyorum..

Ekte nasıl bir liste yapmaya çalıştığımı anlattım..
Yardımcı olabilirseniz sevinirim.

 

[hamitcan]

Sub Test()
    c = 15
    For Each hcr In [c3:q9]
        If hcr.Interior.Color = vbYellow Then
            c = c + 1
            Cells(c, 1) = Cells(hcr.Row, 2)
            Cells(c, 2) = Cells(2, hcr.Column)
        End If
    Next
End Sub

 

[ozijikanu]

Teşekkür ederim..

Ancak, şöyle bir sorum daha olacak
Anladığım kadarıyla, c=15 dediğiniz, listenin oluşacağı yer oluyor. Ben örnek olduğu için aynı sheet içinde liste yapmayı sormuştum. Normalde, listeyi ayrı bir sheet te yapmam gerekiyor. Bunu nasıl belirtebilirim? Örneğin, listeyi sheet2 de oluşturmak istersek??

Bir de, yazdığınız kod ile tüm sarı renkler alt alta sıralanıyor. Benim istediğim ise, ilk değeri almak.. Belki tüm listeyi oluşturduktan sonra minimum değerler diye formül ile düzenlenir ama kodların içine ekleyebilirsek daha kolay olur..

Yardım ederseniz sevinirim.

 

[hamitcan]

Sub Test()
    c = 1
    For Each hcr In Sheets("Sheet1").[c3:q9]
        If hcr.Interior.Color = vbYellow Then
        If Sheets("Sheet1").Cells(hcr.Row, hcr.Column + 1).Interior.Color = vbYellow Then
            c = c + 1
            Sheets("Sheet2").Cells(c, 1) = Sheets("Sheet1").Cells(hcr.Row, 2)
            Sheets("Sheet2").Cells(c, 2) = Sheets("Sheet1").Cells(2, hcr.Column)
        End If
        End If
    Next
End Sub

 

[ozijikanu]

Yeniden teşekkürler,
Yalnız son bir ricam olacak.İş biraz daha karmaşık hale geldi.. Sadece sarı olan değerleri değil, pembe olan değerleri de bulup bir karşılaştırma yapmam gerekiyor. Yeni dosyayı ekledim, yaptığınız makroyu da kendime göre düzenledim. Bakabilir misiniz?
Bu konuyu çözebilirsek, manuel olarak yaptığımız önemli bir işi kolayca çözebilir hale geleceğiz Tabiki yardımınız sayesinde..

 

[ozijikanu]

Ayrıca, sarı renk için vbyellow demişsiniz. Bütün renklerin karşılıklarını bulabileceğim bir yer var mı? Her seferinde foruma sormak zorunda kalmıyım Belki bu şekilde bir liste yayınlanabilirse diğer kullanıcılar da faydalanabilir..

 

[hamitcan]

Bu şekilde deneyin.

Sub Test2()
    c = 1
    With Sheets("Sheet1")
    For Each hcr In .[c3:v9]
        If hcr.Interior.ColorIndex = 38 Then
        If hcr.Offset(0, 1).Interior.ColorIndex <> 38 Then
        For Each hcr2 In .Range(hcr.Address & ":" & "v" & hcr.Row)
        If hcr2.Interior.ColorIndex = 6 Then
            c = c + 1
            Sheets("Sheet2").Cells(c, 2) = .Cells(2, hcr.Column)
            Sheets("Sheet2").Cells(c, 1) = .Cells(hcr2.Row, 2)
            Sheets("Sheet2").Cells(c, 3) = .Cells(2, hcr2.Column)
            GoTo 10
        End If
        Next
        End If
        End If
10:
    Next
    End With
End Sub

 

[ozijikanu]

Gönderdiğinizi aynen kopyaladım.
Object required hatası veriyor..

 

[hamitcan]

Sheet2 isimli bir sayfanız olmalı.

 

[hamitcan]

Kodları düzenledim.

 

[ozijikanu]

Teşekkürler yeniden.
Kodlar örnek dosyada çalışıyor.Ancak, daha karmaşık olan gerçek dosyada yapmaya çalışınca yapamıyorum, şu anda deniyorum. Olmazsa orjinal dosyayı gönderip, sizi yeniden uğraştırabilir miyim

 

[ozijikanu]

Dosyaya uygulayabildim.
Ancak, şöyle bir durum var.. Bazı satırlarda, pembe işlem bitmiş olabiliyor. Sadece sarı işlem kalmış oluyor. Ancak biz burada, pembeden sonraki sarının değerini alalım dediğimiz için bu değerleri göremiyoruz.
Aslında şöyle olmalıydı: Satırda hiç pembe yoksa, ilk sarıya karşılık gelen tarih de yazılsın..
Pembe varsa, yazdığınız kod geçerli..

Zor olacaksa, bu haliyle bırakalım..

 

[hamitcan]

Bir deneme yaptım doğru çıktı, siz de bir kaç deneme yapmalısınız.

Sub Test3()
    c = 1
With Sheet1
    For Each hcr3 In .[c3:v9]
    d = d + 1
    If d = 14 Then d = 0: pembe = False: sari = False: GoTo 20
    If hcr3.Interior.ColorIndex = 6 Then sari = True
    If hcr3.Interior.ColorIndex = 38 Then pembe = True
    
    
    If d = 13 Then
    If sari = True And pembe = False Then
    MsgBox hcr3.Row & ". satırda sadece sarı var"
    c = c + 1
                For Each hcr4 In .Range(.Cells(hcr3.Row, 3), .Cells(hcr3.Row, 13))
                If hcr4.Interior.Color = vbYellow Then
                If .Cells(hcr4.Row, hcr4.Column + 1).Interior.Color = vbYellow Then
                    Sheets("Sayfa2").Cells(c, 1) = .Cells(hcr4.Row, 2)
                    Sheets("Sayfa2").Cells(c, 2) = .Cells(2, hcr4.Column)
                End If
                End If
                Next
    ElseIf sari = True And pembe = True Then
        If hcr3.Offset(0, 1).Interior.ColorIndex <> 38 Then
        MsgBox hcr3.Row & ". satırda hem pembe hem sarı var"
        c = c + 1
                For Each hcr In .Range(Cells(hcr3.Row, 3), Cells(hcr3.Row, 13)).Cells
                If hcr.Interior.ColorIndex = 38 Then
                If hcr.Offset(0, 1).Interior.ColorIndex <> 38 Then
                For Each hcr2 In .Range(hcr.Address & ":" & "v" & hcr.Row)
                If hcr2.Interior.ColorIndex = 6 Then
                    Sayfa1.Cells(c, 2) = .Cells(2, hcr.Column)
                    Sayfa1.Cells(c, 1) = .Cells(hcr2.Row, 2)
                    Sayfa1.Cells(c, 3) = .Cells(2, hcr2.Column)
                End If
                Next
                End If
                End If
                Next
GoTo 20
    End If
    End If
    End If
20:
    Next
End With
MsgBox "İşlem Bitti"
End Sub