Soru Hücre rengine göre sayfalara aktarma

[NADİR YILDIZ]

Arkadaşlar günaydın
ekteki dosyamda sayfa 1 deki B sütunundaki benzerleri koşullu biçimlendirme ile renklendiriyorum.
B sütunundaki renkli olanları renkli sayfasına.renksiz olanları renksiz sayfasına makro ile nasıl aktarabiliriz.
aktarırken Sayfa1 deki veriler silinmeyecek.

iyi çalışmalar

 

[Necdet]

Merhaba,

Daha önce aktarılanlar ne olacak? Yoksa aktarma işi tek seferde mi olacak?

 

[NADİR YILDIZ]

Merhaba Necdet bey
bilgiler devamlı yenilendiği için silmeye gerek yok sayfa1 aynen kalacak
tek seferde aktarılacak sayfa1 deki bilgiler renkli ve renksiz olan sayfalara aktarılacak

iyi çalışmalar

 

[Ömer]

Nadir Bey,
Necdet Beyin sorduğu, kodları çalıştırınca "renkli" ve "renksiz" sayfalarındaki değerler her seferinde silinip yeni değerler mi aktarılacak yok, eski değerlerin altına ilavemi olacak.

 

[NADİR YILDIZ]

Ömer bey
Silinip yeni değerler aktarılacak

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Sub Aktar()

    Dim s1  As Worksheet, _
        sr  As Worksheet, _
        sz  As Worksheet, _
        i   As Long, _
        j   As Long, _
        k   As Long, _
        l   As Long, _
        Adt As Integer, _
        r1  As Integer, _
        r2  As Integer
        
    Set s1 = Sheets("Sayfa1")
    Set sr = Sheets("RENKLİ")
    Set sz = Sheets("RENKSİZ")
    
    k = 3
    l = 3
    
    j = s1.Cells(Rows.Count, "B").End(3).Row
    If j < 6 Then j = 6
    
    Application.ScreenUpdating = False
    sr.Range("A4:M" & Rows.Count).ClearContents
    sz.Range("A4:M" & Rows.Count).ClearContents
    
    For i = 6 To j
    
        Adt = 0
        Adt = Application.WorksheetFunction.CountIf(s1.Range("B6:B" & j), s1.Cells(i, "B"))
        If Adt > 1 Then
            k = k + 1
            r1 = r1 + 1
            s1.Range("B" & i).Copy sr.Cells(k, "A")
            s1.Range("F" & i & ":Q" & i).Copy sr.Cells(k, "B")
        Else
            l = l + 1
            r2 = r2 + 1
            s1.Range("B" & i).Copy sz.Cells(l, "A")
            s1.Range("F" & i & ":Q" & i).Copy sz.Cells(l, "B")
        End If
        
    Next i
    
    MsgBox r1 & " Adet RENKLİ, " & r2 & " Adet RENKSİZ Aktarılmıştır...."
    
    Application.ScreenUpdating = True
    
End Sub

 

[NADİR YILDIZ]

Necdet bey teşekkür ederim.
ancak renkli ve renksiz sayfalarda B sütunundaki sorun nereden kaynaklanıyor

iyi çalışmalar

 

[Necdet]

Merhaba,

Örnek dosyanızda formül yoktu. Aşağıdaki gibi deneyin.

Private Sub CommandButton1_Click()

 Dim s1  As Worksheet, _
        sr  As Worksheet, _
        sz  As Worksheet, _
        i   As Long, _
        j   As Long, _
        k   As Long, _
        l   As Long, _
        Adt As Integer, _
        r1  As Integer, _
        r2  As Integer
        
    Set s1 = Sheets("Sayfa1")
    Set sr = Sheets("RENKLİ")
    Set sz = Sheets("RENKSİZ")
    
    k = 3
    l = 3
    
    j = s1.Cells(Rows.Count, "B").End(3).Row
    If j < 6 Then j = 6
    
    Application.ScreenUpdating = False
    sr.Range("A4:M" & Rows.Count).ClearContents
    sz.Range("A4:M" & Rows.Count).ClearContents
    
    For i = 6 To j
    
        Adt = 0
        Adt = Application.WorksheetFunction.CountIf(s1.Range("B6:B" & j), s1.Cells(i, "B"))
        If Adt > 1 Then
            k = k + 1
            r1 = r1 + 1
            s1.Range("B" & i).Copy sr.Cells(k, "A")
            s1.Range("F" & i & ":Q" & i).Copy
            sr.Range("B" & k).PasteSpecial Paste:=xlPasteValues
        Else
            l = l + 1
            r2 = r2 + 1
            s1.Range("B" & i).Copy sz.Cells(l, "A")
            s1.Range("F" & i & ":Q" & i).Copy
            sz.Range("B" & l).PasteSpecial Paste:=xlPasteValues
        End If
        
    Next i
    
    MsgBox r1 & " Adet RENKLİ, " & r2 & " Adet RENKSİZ Aktarılmıştır...."
    
    Application.ScreenUpdating = True
    
End Sub

 

[NADİR YILDIZ]

Teşekkür ederim Necdet bey

iyi çalışmalar

 

[Korhan Ayhan]

Alternatif;

Hız olarak avantaj sağlayacaktır.

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Zaman As Double
    Dim Dizi As Object, Veri As Variant, Son As Long, X As Long
    Dim Say_A As Long, Say_B As Long, Y As Byte, Sutun As Byte
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("RENKLİ")
    Set S3 = Sheets("RENKSİZ")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    S2.Range("A4:M" & S2.Rows.Count).ClearContents
    S3.Range("A4:M" & S3.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 6 Then Son = 7
    
    Veri = S1.Range("B6:Q" & Son).Value
    
    ReDim Renkli(1 To Son, 1 To 13)
    ReDim Renksiz(1 To Son, 1 To 13)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Dizi.Add Veri(X, 1), 1
        Else
            Dizi.Item(Veri(X, 1)) = Dizi.Item(Veri(X, 1)) + 1
        End If
    Next
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Sutun = 0
        If Dizi.Item(Veri(X, 1)) > 1 Then
            Say_A = Say_A + 1
            For Y = 1 To 16
                Select Case Y
                    Case 2 To 4
                    Case Else
                        Sutun = Sutun + 1
                        Renkli(Say_A, Sutun) = Veri(X, Y)
                End Select
            Next
        ElseIf Dizi.Item(Veri(X, 1)) = 1 Then
            Say_B = Say_B + 1
            For Y = 1 To 16
                Select Case Y
                    Case 2 To 4
                    Case Else
                        Sutun = Sutun + 1
                        Renksiz(Say_B, Sutun) = Veri(X, Y)
                End Select
            Next
        End If
    Next

    S2.Range("D4:E" & S2.Rows.Count).NumberFormat = "@"
    S2.Range("I4:I" & S2.Rows.Count).NumberFormat = "@"
    S3.Range("D4:E" & S3.Rows.Count).NumberFormat = "@"
    S3.Range("I4:I" & S3.Rows.Count).NumberFormat = "@"
    
    S2.Range("A4").Resize(Say_A, 13) = Renkli
    S3.Range("A4").Resize(Say_B, 13) = Renksiz
    
    S2.Columns.AutoFit
    S3.Columns.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set Dizi = Nothing
    
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
    
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[NADİR YILDIZ]

Korhan bey günaydın

hız açısından avantajlı ancak sizin aktarımda sorunmu var benmi yanlış bişey yaptım acaba

iyi çalışmalar

 

[Korhan Ayhan]

Kopyala-yapıştır yaptıktan sonra değişiklik yapmayı unutmuşum. Sorun bundan oluşmuş.

Üstte ki mesajımda ki kodu güncelledim. Son halini deneyiniz.

 

[NADİR YILDIZ]

Teşekkür ederim Korhan bey
gayet güzel çalışıyor.
iyi çalışmalar