Renkli hücreleri aktar

[beyaz34]

Üstadlar tekrar merhaba..
1 Sayfadaki Renkli hüçreleri / 2 Sayfaya aktarmak iştiyorum ?

 

[Necdet]

Merhaba,

Aşağıdaki Kodları Dener misiniz?

Private Sub CommandButton1_Click()
Dim s2 As Worksheet
Dim i As Long
Dim j As Integer
Dim Sut As Integer
Dim Sat As Long
Dim Hucre As Range
Set s2 = Sheets("Sayfa2")
Sut = [IV1].End(1).Column
For j = 1 To Sut
    Sat = 0
    For Each Hucre In Columns(j).SpecialCells(xlCellTypeConstants, 23)
        If Hucre.Interior.ColorIndex <> xlNone Then
            Sat = Sat + 1
            s2.Cells(Sat, j) = Hucre
        End If
    Next Hucre
Next j
End Sub

 

[beyaz34]

Üstad Necdet Yeşertener ellerine klavyene sağlık .
İyi günler dilerim...

 

[Ömer]

Merhaba,

Alternatif olsun.

Option Explicit
 
Private Sub CommandButton1_Click()
Dim S1 As Worksheet, j As Integer, Sat As Long, Hucre As Range
Set S1 = Sheets("Sayfa2")
    For Each Hucre In Range("A2:AA" & [A65536].End(3).Row)
        If Hucre.Interior.ColorIndex <> xlNone Then
            j = Hucre.Column
            Sat = S1.Cells(65536, j).End(3).Row + 1
            S1.Cells(Sat, j) = Hucre.Value
        End If
    Next Hucre
S1.Cells.EntireColumn.AutoFit
Set S1 = Nothing
End Sub

.

 

[beyaz34]

2 Renkli hüçre

Herkeze günaydın arkadaşlar.
2 Renkli hüçre
sayfa1 deki bilgileri 65000 satırlık olan .
1 hücre sarı renk ile isaretli sayfa2 aktarıyor.
2 hücre turkuaz renk ile isaretli sayfa3 aktarmak istiyorum?

 

[Ömer]

Bu şekilde deneyin..

Option Explicit
 
Private Sub CommandButton1_Click()
Dim S1 As Worksheet, j As Integer, Sat As Long, Hucre As Range
Set S1 = Sheets("Sayfa2")
    For Each Hucre In Range("A2:AA" & [A65536].End(3).Row)
        If Hucre.Interior.ColorIndex = 6 Then
            j = Hucre.Column
            Sat = S1.Cells(65536, j).End(3).Row + 1
            S1.Cells(Sat, j) = Hucre.Value
        End If
    Next Hucre
S1.Cells.EntireColumn.AutoFit
Set S1 = Nothing
End Sub
 
Private Sub CommandButton2_Click()
Dim S1 As Worksheet, j As Integer, Sat As Long, Hucre As Range
Set S1 = Sheets("Sayfa3")
    For Each Hucre In Range("A2:AA" & [A65536].End(3).Row)
        If Hucre.Interior.ColorIndex = 8 Then
            j = Hucre.Column
            Sat = S1.Cells(65536, j).End(3).Row + 1
            S1.Cells(Sat, j) = Hucre.Value
        End If
    Next Hucre
S1.Cells.EntireColumn.AutoFit
Set S1 = Nothing
End Sub

.

 

[beyaz34]

Ömer Hoçam çok güzel aktarıyor yalnızca eski verileri silip yenisi yazmasını istiyorum ?

 

[Ömer]

Her iki kod da Set S1 satırından sonra aşağıdaki kodu ekleyerek deneyiniz..

S1.Range("A2:Z65536").ClearContents

.

 

[beyaz34]

Ömer Hoçam çok güzel eline koluna sağlık tesekkürler.............