renge göre kopylama yapmak mümkünmü

[hurkanpisirici]

renge göre kopyalama yapmaya yarayan kod yada fonksiyon varmı acaaba istediğim dosyanın içindedir

 

[Necdet]

Renge Göre Kopyalama

Merhaba,

Değişik yöntemlerle yapılabilir, fikir vermesi açısından dosyayı inceleyebilirsiniz.

Aktar butonuna basmadan önce hangi renkli hücrelerin aktarılacağını anlamak için örnek bir hücre seçtikten sonra butona basabilirsiniz.

Public Sub Aktar()
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s1.Select
s2.Range("A2:P65536").ClearContents
Değer = Selection.Address
Renk = s1.Range(Değer).Interior.ColorIndex
J = 2
For i = 2 To [A65536].End(3).Row
    If Cells(i, "A").Interior.ColorIndex = Renk Then
        s2.Cells(J, "A") = s1.Cells(i, "A")
        s2.Cells(J, "B") = s1.Cells(i, "B")
        s2.Cells(J, "C") = s1.Cells(i, "C")
        s2.Cells(J, "D") = s1.Cells(i, "D")
        s2.Cells(J, "E") = s1.Cells(i, "E")
        s2.Cells(J, "F") = s1.Cells(i, "F")
        s2.Cells(J, "G") = s1.Cells(i, "G")
        s2.Cells(J, "H") = s1.Cells(i, "H")
        s2.Cells(J, "I") = s1.Cells(i, "I")
        s2.Cells(J, "J") = s1.Cells(i, "J")
        s2.Cells(J, "K") = s1.Cells(i, "K")
        s2.Cells(J, "L") = s1.Cells(i, "L")
        s2.Cells(J, "M") = s1.Cells(i, "M")
        s2.Cells(J, "N") = s1.Cells(i, "N")
        s2.Cells(J, "O") = s1.Cells(i, "O")
        s2.Cells(J, "P") = s1.Cells(i, "P")
        J = J + 1
        Adet = Adet + 1
    End If
Next i
If Adet > 0 Then
    MsgBox Adet & " Adet Kayıt Aktarılmıştır..."
Else
    MsgBox "Aktarılacak Kayıt Bulunamadı"
End If
End Sub

 

[Seyit Tiken]

A sütununda veri olan satırı çift tıklayarak sayfa2'ye veri aktarabilirsiniz. İlgili dosya ektedir.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Range(Selection, Selection.End(xlToRight)) _
.Copy Destination:=[sayfa2!a6500].End(3).Offset(1)
[a1].Select
MsgBox "Aktarma yapıldı", vbInformation
End Sub

 

[Recep İpek]

Aşağıdaki kodlarıda deneyebilirsiniz.

Sub Listele()
On Error Resume Next
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
s2.Range("a2:p5000").ClearContents
For i = 2 To s1.[a65536].End(3).Row
    If s1.Cells(i, "a").Interior.ColorIndex = 7 Then   '7 Pembe renk kodu.
        sat = s2.[a65536].End(3).Row + 1
        Range(s2.Cells(sat, "a"), s2.Cells(sat, "p")).Value = Range(s1.Cells(i, "a"), s1.Cells(i, "p")).Value
    End If
Next i
s2.Select
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
MsgBox "Bitti"
End Sub

 

[AS3434]

bir kodda ben yazayım.

Sub RenkAktar()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
For i = 2 To s1.[a65536].End(3).Row
w = s2.[a65536].End(3).Row + 1
If Cells(i, 1).Interior.ColorIndex = [COLOR="Magenta"]7 Then[/COLOR]
s2.Rows(w).Value = s1.Rows(i).Value
End If
Next i
End Sub

7 Then rengi olanlar aktarılır.

 

[hurkanpisirici]

çok teşekkürler

hepinize çok teşekkürler harikasınız