renkli hücreleri alt alta dizmek

[ziraatci26]

arkadaşlar ekte gönderdiğim dosyada her satırda farklı sutunlarda 2 veri var.
Bu verileri sayfa2 de olduğu gibi renksiz hücreleri e sutunuda renkli hücreleri g sutununda alt alta yerleştirmek istiyorumYardımcı olursanız sevinirim.

 

[Orion1]

Dosyanız ekte.

Sub diz()
Dim sat As Long, sut As Integer, i As Long
Sheets("Sayfa1").Select
sat = 1
Application.ScreenUpdating = False
With Sheets("Sayfa2")
    .Range("A1:G65536").ClearContents
    .Range("G1:G65536").Interior.ColorIndex = xlNone
    For i = 1 To Cells(65536, "A").End(xlUp).Row
        For sut = 2 To 256
            If Cells(i, sut).Value <> "" Then
                .Cells(sat, "A").Value = Cells(i, "A").Value
                If Cells(i, sut).Interior.ColorIndex = xlNone Then
                    .Cells(sat, "E").Value = Cells(i, sut).Value
                    Else
                    .Cells(sat, "G").Value = Cells(i, sut).Value
                    .Cells(sat, "G").Interior.ColorIndex = Cells(i, sut).Interior.ColorIndex
                End If
            End If
        Next sut
        sat = sat + 1
    Next i
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamam"
    
                
End Sub

 

[ziraatci26]

hocam ilginden dolayı teşekkür ederim.Ancak makro eksik çalışıyo.renksiz olan hücreleride e sutunnda alt alt yerleştirmem renkli olanları g sutununda alt alta yerleştirmem gerekiyo.Mevcut makro sadece renlki hücreleri e sutununda alt alta yerleştiriyor.yardımlarınızı bekliyorum.saygılarımla

 

[Orion1]

hocam ilginden dolayı teşekkür ederim.Ancak makro eksik çalışıyo.renksiz olan hücreleride e sutunnda alt alt yerleştirmem renkli olanları g sutununda alt alta yerleştirmem gerekiyo.Mevcut makro sadece renlki hücreleri e sutununda alt alta yerleştiriyor.yardımlarınızı bekliyorum.saygılarımla

Kod eksik değil.
Tamda dediğiniz gibi çalışıyor.Şimdi size yolladığım dosyayı tekrardan çalıştırdım..E sütununda alt lata renksiz hücreleri listeledi.Zaten size yolladığım dosyaya hiç bir şey yapmadanda baksnız yine e sütununda renksiz hücrelerin alt alta listelendiğini göreceksiniz.

 

[ziraatci26]

sayın hocam.ben olayı yanlış anlattım tabi sizde ona göre çözüm ürettiniz.eliniz dert görmesin.ben olayı bi daha anlatırsam umarım olayı netliğe kavuşturacaz. A sutununda bulunan veriler sabit veriler.Bunların yanlarında b sutunundan başlayıp g sutunu aralığına dağılmış ancak her satırda 2 adet bulanan veriler var.yani bizim bir satırımızda a sutunu ile g sutunu arasında 3 hucrede veri var.Bu verilerden 1 tanesi hep A sutununda diğerleride b ile g sutunu arasında.B ile g sutunu arasında bulunan verilerden 1 tanesinin hücre rengi kımızı diğeri ise renksiz.İşte ben bu noktada b ile g sutunu arasında bulunan verilerden rensiz olanları ve kırmız renkli olanları alt alta geimek istiyorum.Saygılarımla umarım yardımcı olursunuz

 

[ziraatci26]

olayı renkli bi şekilde anlatmak gerekirse örnek ektedr hocamyardımlarınızı bekliyorum.saygılarımla

 

[Orion1]

Dosyanız ekte.

Sub diz()
Dim sat As Long, sut As Integer, i As Long
Sheets("Sayfa1").Select
sat = 1
Application.ScreenUpdating = False
With Sheets("Sayfa2")
    .Range("A1:G65536").ClearContents
    .Range("E1:E65536").Interior.ColorIndex = xlNone
    .Range("G1:G65536").Interior.ColorIndex = xlNone
    For i = 1 To Cells(65536, "A").End(xlUp).Row
        For sut = 2 To 7
            If Cells(i, sut).Value <> "" Then
                .Cells(sat, "A").Value = Cells(i, "A").Value
                If Cells(i, sut).Interior.ColorIndex = 6 Then
                    .Cells(sat, "E").Value = Cells(i, sut).Value
                    .Cells(sat, "E").Interior.ColorIndex = 6
                    ElseIf Cells(i, sut).Interior.ColorIndex = 3 Then
                    .Cells(sat, "G").Value = Cells(i, sut).Value
                    .Cells(sat, "G").Interior.ColorIndex = 3
                End If
            End If
        Next sut
        sat = sat + 1
    Next i
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamam"
    
                
End Sub

 

[ziraatci26]

hocam çok teşekkürler.Emeğine sağlık