Dolgu rengine göre sırala

[baydeniro]

Merhaba arkadaşlar,

Dolgu Rengine göre verileri sıralatmak mümkün mü ? C-D-E-F sütunlarında bulunan verilerden her satırda 1 tanesi YEŞİL, 1 tanesi KIRMIZI renk ile işaretlenmiş. Her satırda 2 hücre ise renkli değil.

Bu verilerden YEŞİL olanı H sütununa, KIRMIZI olanı I sütununa, renksiz olanlardan solda olanı J sütununa, renksiz olanlardan sağda olanı K sütununa kopyalamak mümkün mü ?

Örnek dosya ve beklenen çözüm örneği aşağıdaki linktedir ;

http://s6.dosya.tc/server11/ek0z0w/___Dolgu_Rengine_Gore_Sirala.xls.html

 

[antonio]

Aşağıdaki kodları kopyalayıp, Örnek dosyanızdaki modüle yapıştırnız ve DATA sayfasındaki düğmeye kodları bağlayınız.

Sub renkleri_hizala()
Dim sh As Worksheet, ss As Long, sat As Long, y As Long, k As Long, b1 As Long, b2 As Long

y = 2:  k = 2:  b1 = 2: b2 = 2
Set sh = Sheets("DATA")
ss = sh.Range("A:F").Find("*", , , , xlByRows, xlPrevious).Row
sh.Range("H2:K" & Rows.Count).Interior.ColorIndex = xlNone
sh.Range("H2:K" & Rows.Count).ClearContents
For i = 2 To ss
    For a = 3 To 6
        If Cells(i, a).Interior.ColorIndex = 3 Then
            sh.Range("I" & k).Value = Cells(i, a).Value
            sh.Range("I" & k).Interior.ColorIndex = 3
            k = k + 1
        ElseIf Cells(i, a).Interior.ColorIndex = 14 Then
            sh.Range("H" & y).Value = Cells(i, a).Value
            renk = Cells(i, a).Interior.Color
            
            sh.Range("H" & y).Interior.Color = renk
            y = y + 1
        
        ElseIf Cells(i, a).Interior.ColorIndex = xlNone Then
            If b1 = b2 Or b1 < b2 Then
                sh.Range("J" & b1).Value = Cells(i, a).Value
                b1 = b1 + 1
            ElseIf b1 > b2 Then
                sh.Range("K" & b2).Value = Cells(i, a).Value
                b2 = b2 + 1
            End If
        End If
    Next a
Next i
MsgBox "İşlem tamamlandı.", vbInformation, "RENLERE GÖRE SIRALAMA İŞLEMİ"
Set sh = Nothing
End Sub

 

[baydeniro]

Sayın antonio çok çok teşekkür ediyorum. Hayal gibi bir şey. Yapılabilirliğine pek ihtimal vermiyordum. Gerçekten harika bir kod olmuş. Emeğinize, aklınıza sağlık. Sağlıcakla kalın.

 

[Ömer BARAN]

Merhaba.

Alternatif olsun.
NOT: Kod'u biraz kısalttım 09.09.2017 20:26
.

[B]Sub OZEL_LISTELE()[/B]
Range("H2:K" & Cells(Rows.Count, 3).End(xlUp).Row).Clear
For sat = 2 To Cells(Rows.Count, 3).End(xlUp).Row
    For sut = 3 To 6
        If Cells(sat, sut).Interior.ColorIndex = 14 Then
            satirH = Cells(Rows.Count, "H").End(xlUp).Row + 1
            Cells(sat, sut).Copy Cells(satirH, "H")
        ElseIf Cells(sat, sut).Interior.ColorIndex = 3 Then
            satirI = Cells(Rows.Count, "I").End(xlUp).Row + 1
            Cells(sat, sut).Copy Cells(satirI, "I")
        Else
            ss = ss + 1: satt = Cells(Rows.Count, ss + 9).End(xlUp).Row + 1
            Cells(sat, sut).Copy Cells(satt, ss + 9)
        End If
    Next: ss = 0
Next
Application.CutCopyMode = False
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B]End Sub[/B]

 

[antonio]

Sayın antonio çok çok teşekkür ediyorum.

Rica ederim. İşinize yaradıysa ne mutlu!.. Sağlıcakla kalın..

 

[baydeniro]

Ömer Baran üstadım çok çok teşekkürler. Harika bir alternatif oldu. Emeğinize, bilginize, aklınıza sağlık. Sağlık, esenlik diliyorum.

 

[Ömer BARAN]

Ömer Baran üstadım çok çok teşekkürler. Harika bir alternatif oldu. Emeğinize, bilginize, aklınıza sağlık. Sağlık, esenlik diliyorum.

Kolay gelsin.
.