• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Hücre rengine göre sayfalara aktarma

NADİR YILDIZ

NADİR YILDIZ

Altın Üye
Katılım
7 Ocak 2006
Mesajlar
1,418
Excel Vers. ve Dili
2016 Türkçe
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
 

Ekli dosyalar

Merhaba,

Daha önce aktarılanlar ne olacak? Yoksa aktarma işi tek seferde mi olacak?
 
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
 
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.
 
Merhaba,

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

Kod: 
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
 
Necdet bey teşekkür ederim.
ancak renkli ve renksiz sayfalarda B sütunundaki sorun nereden kaynaklanıyor

iyi çalışmalar
 

Ekli dosyalar

Merhaba,

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

Kod: 
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
 
Alternatif;

Hız olarak avantaj sağlayacaktır.

C++: 
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
 
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
 

Ekli dosyalar

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.
 
Teşekkür ederim Korhan bey
gayet güzel çalışıyor.
iyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst