Sutun harfine göre renkli olan satırları aktar

[tahsinanarat]

Ekli örnek dosyamda Liste sayfasının H1 hücresine yazacağım RAPOR sayfasındaki sutun harfine göre sutunda renkli olan hücrelerin bulunduğu satırları Liste Sayfasına aktarmak istiyorum. Renkler Koşullu biçimlendirme ile renklendirilmiştir.
RAPOR sayfasının A-G sutunu ile H1 hücresine yazdığım sutun harfindeki renkli olanların hücre bilgilerini (tarihleri) getirmesini istiyorum.
Yardımcı olabilecek Hocalarıma şimdiden teşekkür ederim.

 

[veyselemre]

Sub test()
    sut = Sheets("Liste").Range("H1").Value
    With Sheets("Rapor")
        Set Rng = .Range(.Cells(2, sut), .Cells(Rows.Count, sut).End(3))
    End With
    sat = 2
    For Each huc In Rng
        If huc.DisplayFormat.Interior.ColorIndex <> xlNone Then
            Sheets("Liste").Cells(sat, "I").Value = huc.Value
            sat = sat + 1
        End If
    Next huc
End Sub

 

[tahsinanarat]

Sn. @veyselemre hocam, hayırlı iftarlarınız olsun, elinize sağlık, tarihler hatasız geliyor, ancak Bunlara ait olan A,b,c,d,e,f,g sutun bilgilerinize getirebilirmiyiz. Çok teşekkürler.

 

[Korhan Ayhan]

Merhaba,

@tahsinanarat bey artık sizin bu tarz kodları yazabileceğinizi düşünüyorum. Veysel bey zaten size anahtarı vermiş. Biraz kurcalarsanız geliştirebilirsiniz.

 

[tahsinanarat]

Aklıma gelenleri denedim, ancak Rapor sayfasındaki renkli sutunların karşılığı değilde saradan getiriyor, denediğim kod

Sheets("Liste").Cells(sat, "a").Value = Sheets("Rapor").Cells(sat, "a")

 

[tahsinanarat]

Sn. @Korhan Ayhan hocam sanırım bu sefer oldu;

Sub test()
    Sut = Sheets("Liste").Range("H1").Value
    With Sheets("Rapor")
        Set Rng = .Range(.Cells(2, Sut), .Cells(Rows.Count, Sut).End(3))
    End With
    sat = 2
    For Each huc In Rng
        If huc.DisplayFormat.Interior.ColorIndex <> xlNone Then
            Sheets("Liste").Cells(sat, "I").Value = huc.Value
            Sheets("Liste").Cells(sat, "a").Value = Sheets("Rapor").Cells(huc.Row, "a")
            Sheets("Liste").Cells(sat, "B").Value = Sheets("Rapor").Cells(huc.Row, "b")
            Sheets("Liste").Cells(sat, "C").Value = Sheets("Rapor").Cells(huc.Row, "c")
            Sheets("Liste").Cells(sat, "D").Value = Sheets("Rapor").Cells(huc.Row, "d")
            Sheets("Liste").Cells(sat, "E").Value = Sheets("Rapor").Cells(huc.Row, "e")
            Sheets("Liste").Cells(sat, "F").Value = Sheets("Rapor").Cells(huc.Row, "f")
            Sheets("Liste").Cells(sat, "G").Value = Sheets("Rapor").Cells(huc.Row, "g")
            sat = sat + 1
        End If
    Next huc
End Sub

 

[Korhan Ayhan]

Tebrikler..

Ek bilgi; Ardışık giden sütunları tek satırda aktarabilirsiniz.

 

[veyselemre]

Sub test()
    Dim sut$, rng As Range, huc As Range, sat&
    sut = Sheets("Liste").Range("H1").Value
    With Sheets("Rapor")
        Set rng = .Range(.Cells(2, sut), .Cells(Rows.Count, sut).End(3))
    End With
    sat = 2
    With Sheets("Liste")
        .Range("A2:I" & .Cells(Rows.Count, 1).End(3).Row).ClearContents
        For Each huc In rng
            If huc.DisplayFormat.Interior.ColorIndex <> xlNone Then
                .Cells(sat, "I").Value = huc.Value
                .Cells(sat, "A").Resize(, 7).Value = Sheets("Rapor").Cells(huc.Row, "a").Resize(, 7).Value
                sat = sat + 1
            End If
        Next huc
    End With
End Sub

 

[tahsinanarat]

Sn. @veyselemre hocam, çok teşekkür ederim. Sağolun, hayırlı Ramazanlar diliyorum.