Soru Benzer olanları başka sayfaya aktarma

[NADİR YILDIZ]

Arkadaşlar zirve sayfasında benzer olanları sarı ile renklendirip Benzer olanlar sayfasına aktarım yapmak istiyorum

 

[RBozkurt]

Merhaba, deneyiniz.

Sub SarıDolguluSatırlarıKopyala()

    Dim wsZirve As Worksheet
    Dim wsBenzerOlanlar As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    
    Set wsZirve = ThisWorkbook.Worksheets("Zirve")
    Set wsBenzerOlanlar = ThisWorkbook.Worksheets("BENZER OLANLAR")
    
    lastRow = wsZirve.Cells(wsZirve.Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
        If wsZirve.Cells(i, "A").Interior.ColorIndex = 6 Then ' 6, sarı renk kodudur
            j = wsBenzerOlanlar.Cells(wsBenzerOlanlar.Rows.Count, "A").End(xlUp).Row + 1
            wsZirve.Range("A" & i & ":N" & i).Copy wsBenzerOlanlar.Range("A" & j)
        End If
    Next i
    
    MsgBox "Sarı dolgulu satırlar kopyalandı."
    
End Sub

 

[NADİR YILDIZ]

Sayın bozkurt öncelikle teşekkür ederim..
renkli olanları aktarım yapıyor
ancak ben benzer olanları vurgulamak adına renklendirip göndermiştim..
yani onlar normal de renkli değil
makro kodunu ona göre revize edebilirmiyiz

iyi çalışmalar

 

[NADİR YILDIZ]

Sayın bozkurt verdiğiniz kodu ekledim ancak hiçbir şey aktarım yapmıyor

 

[RBozkurt]

Edit.

 

[NADİR YILDIZ]

Sayın bozkurt renk olduğu için yapıyor sizdeki
benim istediğim benzerleri renklendirip
kırmızılar benzer ben renklendirdim...
aktarması

 

[RBozkurt]

Merhaba, deneyiniz.
3 adet makro var farklı işlevlere sahip. İlk makroya bağlandı.
Bu sefer sonuçlandı.

Sub Makro1_VeriBirlestir()
    Dim ws As Worksheet
    Dim birlesmisVeri As String
    Dim satir As Integer
    
    Set ws = ThisWorkbook.Sheets("Zirve")
    
    For satir = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
        
        birlesmisVeri = ws.Range("A" & satir).Value & _
                       ws.Range("B" & satir).Value & _
                       ws.Range("F" & satir).Value & _
                       ws.Range("H" & satir).Value & _
                       ws.Range("J" & satir).Value & _
                       ws.Range("K" & satir).Value
        
        ws.Range("Z" & satir).Value = birlesmisVeri
        
    Next satir
    
    Call Makro2_YinelenenleriRenklendir
    Call Makro3_BenzerSayfasinaTasi
End Sub

Sub Makro2_YinelenenleriRenklendir()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cel As Range
    
    Set ws = ThisWorkbook.Sheets("Zirve")
    
    Set rng = ws.Range("Z1:Z" & ws.Cells(Rows.Count, "Z").End(xlUp).Row)
    
    For Each cel In rng
        If WorksheetFunction.CountIf(rng, cel.Value) > 1 Then
            cel.Interior.Color = vbYellow
        End If
    Next cel
    
End Sub

Sub Makro3_BenzerSayfasinaTasi()

    Dim wsZirve As Worksheet
    Dim wsBenzerOlanlar As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    
    Set wsZirve = ThisWorkbook.Worksheets("Zirve")
    Set wsBenzerOlanlar = ThisWorkbook.Worksheets("BENZER OLANLAR")
    
    lastRow = wsZirve.Cells(wsZirve.Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
        If wsZirve.Cells(i, "Z").Interior.ColorIndex = 6 Then ' 6, sarı renk kodudur
            j = wsBenzerOlanlar.Cells(wsBenzerOlanlar.Rows.Count, "A").End(xlUp).Row + 1
            wsZirve.Range("A" & i & ":N" & i).Copy wsBenzerOlanlar.Range("A" & j)
        End If
    Next i
    
    MsgBox "Yinelenen satırlar aktarıldı."
    Sheets("Zirve").Range("Z2:Z" & lastRow).Clear
End Sub

 

[NADİR YILDIZ]

Üstad teşekkür ederim elinize emeğinize sağlık
istediğim gibi olmuş
ancak Alacak tutarınıda ( L sütunu ) aktarıyor..
bunun nedenide A dan J ye kadar olanlar sütunlardaki bilgiler aynı olmasından kaynaklı sanırım..
Alacak tarafında tutar varsa aktarmadan makroda değiştirme yapabilirmiyiz
birde benzer olmayanları başka sayfaya ayrı bir butonla aktarım yapabilirmiyiz.benzer & benzer olmayanlar butonları ayrı olacak şekilde

iyi çalışmalar

 

[RBozkurt]

İlk makroda;
Call Makro3_BenzerSayfasinaTasi satırından sonra
Call Makro4_BenzerOlmayanSayfasinaTasi satırını ekleyin.
Aşağıdaki koduda modüle ekleyin.

Excel'de BENZER OLMAYANLAR sayfasını oluşturun.

Başlık konusunda'da ilgili satırda A:N arasını kopyala yapıştır yapar, başlığınızı Zirve sayfasına göre uydurunuz.

Çok vaktim yok şuan bakamıyorum.

Sub Makro4_BenzerOlmayanSayfasinaTasi()

    Dim wsZirve As Worksheet
    Dim wsBenzerOlanlar As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    
    Set wsZirve = ThisWorkbook.Worksheets("Zirve")
    Set wsBenzerOlanlar = ThisWorkbook.Worksheets("BENZER OLMAYANLAR")
    
    lastRow = wsZirve.Cells(wsZirve.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        If wsZirve.Cells(i, "Z").Interior.ColorIndex = xlNone Then
            j = wsBenzerOlanlar.Cells(wsBenzerOlanlar.Rows.Count, "A").End(xlUp).Row + 1
            wsZirve.Range("A" & i & ":N" & i).Copy wsBenzerOlanlar.Range("A" & j)
        End If
    Next i
    
    MsgBox "Satırlar aktarıldı."
    Sheets("Zirve").Range("Z2:Z" & lastRow).Clear
End Sub

 

[NADİR YILDIZ]

Teşekkürler üstad müsait olduğumda bakacağım
iyi çalışmalar

 

[RBozkurt]

Makro3'de
Sheets("Zirve").Range("Z2:Z" & lastRow).Clear satırını silin veya başına tek tırnak ekleyip ' deneyin. Onu eklemeyi unuttum.

 

[NADİR YILDIZ]

üstad dedikleriniz yaptım
ancak hata veriyor.
atladığım bişey mi var ?

 

[RBozkurt]

Deneyiniz.
Aşağıdaki satıda then eksik kalmış. Kodu değiştirdim.
If wsZirve.Cells(i, "Z").Interior.ColorIndex = xlNone
If wsZirve.Cells(i, "Z").Interior.ColorIndex = xlNone Then

 

[RBozkurt]

Çalışma mantığı şu şekilde;
1-Renklendirdiğiniz sütunları Z'de birleştirir.
2-Z'de Yinelenen değerleri SARI dolgu yapar.
3-SARI dolgu olan satırdaki A:N aralığını Benzer Olan sayfasına,
4-Dolgu olmayan satırdaki A:N aralığını Benzer Olmayan sayfasına, kopyala/yapıştır yapar.
5-Z'yi temizler.

 

[NADİR YILDIZ]

Üstad Çok teşekkür ederim
Allah Razı olsun
sizi uğraştırdım hakkınızı helal edin

iyi çalışmalar

 

[RBozkurt]

Estf. hocam kolay gelsin. Bende çok işimi forumdan destek alarak hallettim/hallediyorum.

 

[Korhan Ayhan]

Alternatif;

ADO ile çözümlenmiştir. Süre olarak avantaj sağlayacaktır.

Option Explicit

Sub List_Duplicate_And_Non_Duplicate_Records_On_Separate_Pages()
    Dim My_Connection As Object, My_Query As String
    Dim My_Recordset As Object, Process_Time As Double
    
    Process_Time = Timer
    
    Set My_Connection = CreateObject("AdoDB.Connection")
    
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    My_Query = "SELECT * FROM [Zirve$A2:N] WHERE F1&F2&F6&F8&F10& IIF(F11=0,F12,F11) " & _
               "IN (SELECT F1&F2&F6&F8&F10 & IIF(F11=0,F12,F11) FROM [Zirve$A2:N] " & _
               "GROUP BY F1,F2,F6,F8,F10,IIF(F11=0,F12,F11) HAVING COUNT(*) > 1)"
    
    Set My_Recordset = My_Connection.Execute(My_Query)
    
    Sheets("BENZER OLANLAR").Range("A2:N" & Rows.Count).ClearContents
    Sheets("BENZER OLANLAR").Range("A2").CopyFromRecordset My_Recordset
    
    My_Query = "SELECT * FROM [Zirve$A2:N] WHERE F1&F2&F6&F8&F10& IIF(F11=0,F12,F11) " & _
               "IN (SELECT F1&F2&F6&F8&F10 & IIF(F11=0,F12,F11) FROM [Zirve$A2:N] " & _
               "GROUP BY F1,F2,F6,F8,F10,IIF(F11=0,F12,F11) HAVING COUNT(*) = 1)"
    
    Set My_Recordset = My_Connection.Execute(My_Query)
    
    Sheets("BENZER OLMAYANLAR").Range("A2:N" & Rows.Count).ClearContents
    Sheets("BENZER OLMAYANLAR").Range("A2").CopyFromRecordset My_Recordset
    
    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
    
    Set My_Recordset = Nothing
    Set My_Connection = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[NADİR YILDIZ]

sayın Korhan ayhan teşekkür ederim..