Mükerrer olan satırları sayfa 2 ye kopyalama

[ceyhunsudur]

örneğin B sütünda olan verilerden mükerrer olanların komple satırı ile birlikte tamamını teke indirmeden sayfa 2 ye aktarması lazım.B sütunundaki mükerrerlerin tamamını aktarabildim fakat satırları aktaramadım.Yardımcı olursanız sevinirim.

 

[asi_kral]

Dosya ekler misiniz_?
Açıklamayı dosya içinde örneklerle yaparsanız yardımcı olabilirim.

 

[ceyhunsudur]

dosya ekte

 

[asi_kral]

dosya ekte

Merhaba

Boş bir module kopyalayın ve deneyin.

------------------------------------

Option Explicit
Sub mük_aktarım_1967()
'Konu : Mükerrer Olanları Aktar
'Coder by : asi_kral_1967
Dim asi, kral
Dim a, b
Set asi = Sheets("Sayfa1"): Set kral = Sheets("Sayfa2")
kral.Range("A2:G" & Rows.Count).ClearContents
b = 2
For a = 2 To asi.Cells(Rows.Count, "B").End(xlUp).Row
If WorksheetFunction.CountIf(asi.Range("B2:B" & Rows.Count), _
asi.Cells(a, "B")) > 1 Then
kral.Cells(b, "A") = asi.Cells(a, "A")
kral.Cells(b, "B") = asi.Cells(a, "B")
kral.Cells(b, "C") = asi.Cells(a, "C")
kral.Cells(b, "D") = asi.Cells(a, "D")
kral.Cells(b, "E") = asi.Cells(a, "E")
kral.Cells(b, "F") = asi.Cells(a, "F")
kral.Cells(b, "G") = asi.Cells(a, "G")
b = b + 1
End If
Next
kral.Range("A2:G" & Rows.Count).Sort key1:=kral.Range("B2"), order1:=xlAscending
MsgBox "Çalışma Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

----------------------------------

Dosyanız ekte

 

[ceyhunsudur]

makro tam istediğim gibi teşşekkür ederim fakat ufak bi eksik var.sayfa 1 deki tüm mükerrerlerde silinecektir.onuda ekledikmi tamamdır.şimdiden yine teşekkürler

 

[asi_kral]

Merhaba
Tam anlayamadım. Şimdi mükerrer olanlar Sayfa1'den silinecek doğru mu anladım_?

 

[ceyhunsudur]

aynen öle ama mükerrlerin tamamı sayfa 1 den silinecek

 

[asi_kral]

aynen öle ama mükerrlerin tamamı sayfa 1 den silinecek

Merhaba
Kodu bununla değiştirip dener misiniz_?

----------------------------------------
Option Explicit
Sub mük_aktarım_1967()
'Konu : Mükerrer Olanları Aktar
'Coder by : asi_kral_1967
Dim asi, kral
Dim a, b
Set asi = Sheets("Sayfa1"): Set kral = Sheets("Sayfa2")
kral.Range("A2:G" & Rows.Count).ClearContents
b = 2
For a = 2 To asi.Cells(Rows.Count, "B").End(xlUp).Row
If WorksheetFunction.CountIf(asi.Range("B2:B" & Rows.Count), _
asi.Cells(a, "B")) > 1 Then
kral.Cells(b, "A") = asi.Cells(a, "A")
kral.Cells(b, "B") = asi.Cells(a, "B")
kral.Cells(b, "C") = asi.Cells(a, "C")
kral.Cells(b, "D") = asi.Cells(a, "D")
kral.Cells(b, "E") = asi.Cells(a, "E")
kral.Cells(b, "F") = asi.Cells(a, "F")
kral.Cells(b, "G") = asi.Cells(a, "G")
kral.Cells(b, "I") = asi.Cells(a, "A") & asi.Cells(a, "B") & asi.Cells(a, "C") & _
asi.Cells(a, "D") & asi.Cells(a, "E") & asi.Cells(a, "F") & asi.Cells(a, "G")
b = b + 1
End If
Next
For a = asi.Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(kral.Range("I2:I" & Rows.Count), _
asi.Cells(a, "A") & asi.Cells(a, "B") & asi.Cells(a, "C") & asi.Cells(a, "D") & _
asi.Cells(a, "E") & asi.Cells(a, "F") & asi.Cells(a, "G")) > 0 Then
asi.Rows(a).Delete
End If
Next
kral.Range("I2:I" & Rows.Count).ClearContents
kral.Range("A2:G" & Rows.Count).Sort key1:=kral.Range("B2"), order1:=xlAscending
MsgBox "Çalışma Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

--------------------------------------------

Dosya Ekte

 

[ceyhunsudur]

tamamdır hocam ellerine sağlık süper oldu çok teşşekkür ederim.

 

[asi_kral]

tamamdır hocam ellerine sağlık süper oldu çok teşşekkür ederim.

Kolay Gelsin