Tekrarlayan satırlar hk.

[smiles]

Merhaba Arkadaşlar,
Bir excel çalışmasında E sütununda tekrar eden değerler var. Toplamda 17500 satırlık bir xls. sayfası olduğundan bunu tek tek bulmam hem güç hem de sanırım anlamsız.
Bu yönde bir arkadaşımız ( irfan bey ) sağolsun dün bir makro yazıp göndermişti ancak istediğim tam olarak ekteki dosyada belirttiğim ayrıntı.

Çalışmanın orjinali 17500 satırlık ancak ben ekteki örneğimde ilk 10 satırlık kısmını gönderiyorum. E Sütununda tekrar eden numaralar bulunup bunların ikinci bir sayfaya aktarılması gerekiyor.
Yardımlarınız için şimdiden teşekkür ederim.

 

[halit3]

Merhaba Arkadaşlar,
Bir excel çalışmasında E sütununda tekrar eden değerler var. Toplamda 17500 satırlık bir xls. sayfası olduğundan bunu tek tek bulmam hem güç hem de sanırım anlamsız.
Bu yönde bir arkadaşımız ( irfan bey ) sağolsun dün bir makro yazıp göndermişti ancak istediğim tam olarak ekteki dosyada belirttiğim ayrıntı.

Çalışmanın orjinali 17500 satırlık ancak ben ekteki örneğimde ilk 10 satırlık kısmını gönderiyorum. E Sütununda tekrar eden numaralar bulunup bunların ikinci bir sayfaya aktarılması gerekiyor.
Yardımlarınız için şimdiden teşekkür ederim.

Bunu denermisiniz.

Sub aktar()
Sheets("Sayfa2").Range("A2:E65000").ClearContents
sat = Worksheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row + 1
For r = 2 To Worksheets("Sayfa1").Cells(Rows.Count, "E").End(3).Row
aranan1 = Sheets("Sayfa1").Cells(r, "E").Value
If Sheets("Sayfa1").Cells(r, "E").Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("Sayfa1").Range("E2:E65000"), aranan1) > 1 Then
Sheets("Sayfa2").Cells(sat, 1).Value = Sheets("Sayfa1").Cells(r, 1).Value
Sheets("Sayfa2").Cells(sat, 2).Value = Sheets("Sayfa1").Cells(r, 2).Value
Sheets("Sayfa2").Cells(sat, 3).Value = Sheets("Sayfa1").Cells(r, 3).Value
Sheets("Sayfa2").Cells(sat, 4).Value = Sheets("Sayfa1").Cells(r, 4).Value
Sheets("Sayfa2").Cells(sat, 5).Value = Sheets("Sayfa1").Cells(r, 5).Value
sat = sat + 1
End If
End If
Next r
MsgBox "işlem tamam"
End Sub

 

[gelibolu]

Kodu kopyaladım kod çoğulları 2. sayfaya aktarıyor Ancak;

benim bunlara ek olarak görmek istediğim bu verilerin 1.sayfadan silinmesi ve sıralamanın yeniden yapılması belki sn. smiles'ın istediği budur.

 

[halit3]

Kodu kopyaladım kod çoğulları 2. sayfaya aktarıyor Ancak;

benim bunlara ek olarak görmek istediğim bu verilerin 1.sayfadan silinmesi ve sıralamanın yeniden yapılması belki sn. smiles'ın istediği budur.

kod

Sub aktar2()
Sheets("Sayfa2").Range("A2:E65000").ClearContents
sat = Worksheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row + 1
For r = 2 To Worksheets("Sayfa1").Cells(Rows.Count, "E").End(3).Row
aranan1 = Sheets("Sayfa1").Cells(r, 5).Value
If Sheets("Sayfa1").Cells(r, 5).Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("Sayfa1").Range("E2:E" & r), aranan1) > 1 Then
For i = Worksheets("Sayfa1").Cells(Rows.Count, "E").End(3).Row To 2 Step -1
aranan2 = Sheets("Sayfa1").Cells(i, 5).Value
If aranan2 = aranan1 Then
Sheets("Sayfa2").Cells(sat, 1).Value = Sheets("Sayfa1").Cells(i, 1).Value
Sheets("Sayfa2").Cells(sat, 2).Value = Sheets("Sayfa1").Cells(i, 2).Value
Sheets("Sayfa2").Cells(sat, 3).Value = Sheets("Sayfa1").Cells(i, 3).Value
Sheets("Sayfa2").Cells(sat, 4).Value = Sheets("Sayfa1").Cells(i, 4).Value
Sheets("Sayfa2").Cells(sat, 5).Value = Sheets("Sayfa1").Cells(i, 5).Value
sat = sat + 1
Sheets("Sayfa1").Rows(i).Delete Shift:=xlUp
End If
Next i
End If
End If
Next r
MsgBox "işlem tamam"
End Sub

 

[halit3]

Bu kodda teke indiriyor.

Sub aktar3()
Sheets("Sayfa2").Range("A2:E65000").ClearContents
sat = Worksheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row + 1
For r = 2 To Worksheets("Sayfa1").Cells(Rows.Count, "E").End(3).Row
aranan1 = Sheets("Sayfa1").Cells(r, 5).Value
If Sheets("Sayfa1").Cells(r, 5).Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("Sayfa1").Range("E2:E" & r), aranan1) > 1 Then
For i = Worksheets("Sayfa1").Cells(Rows.Count, "E").End(3).Row To r Step -1
aranan2 = Sheets("Sayfa1").Cells(i, 5).Value
If aranan2 = aranan1 Then
Sheets("Sayfa2").Cells(sat, 1).Value = Sheets("Sayfa1").Cells(i, 1).Value
Sheets("Sayfa2").Cells(sat, 2).Value = Sheets("Sayfa1").Cells(i, 2).Value
Sheets("Sayfa2").Cells(sat, 3).Value = Sheets("Sayfa1").Cells(i, 3).Value
Sheets("Sayfa2").Cells(sat, 4).Value = Sheets("Sayfa1").Cells(i, 4).Value
Sheets("Sayfa2").Cells(sat, 5).Value = Sheets("Sayfa1").Cells(i, 5).Value
sat = sat + 1
Sheets("Sayfa1").Rows(i).Delete Shift:=xlUp
End If
Next i
End If
End If
Next r
MsgBox "işlem tamam"
End Sub

 

[smiles]

Sevgili arkadaşlar,
Cevaplarınıza ve ilginize çok teşekkür ederim. Sayenizde problemim aşılmış oldu.
Emeğinize sağlık..

 

[halit3]

Sevgili arkadaşlar,
Cevaplarınıza ve ilginize çok teşekkür ederim. Sayenizde problemim aşılmış oldu.
Emeğinize sağlık..

İyi çalışmalar