B ve C sütunlarındaki tekrarlanan veriler

[kelkitli]

Değerli Dostlar Selamlar,
Sayfa1 de A:G aralığında verilerim var. B17:B ve C17:C sütunlarında ad, soyad yazılı. Adı soyadı aynı olan kişilerin tekrarlanan verilerini A:G aralığı olarak Sayfa2 ye aktarmak istiyorum. Veri tekrarı Sayfa1 den silinip, Sayfa2 ye aktarılması gerekiyor.

 

[N.Ziya Hiçdurmaz]

yanıt

Sub tekraredenler()
Dim sat, s As Integer
s = 2
With Sayfa1
    For sat = 18 To 26
        If WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) > 1 Then
        Range(.Cells(sat, "a"), .Cells(sat, "g")).Cut Sayfa2.Cells(s, "a")
        s = s + 1
        End If
    Next
End With
End Sub

 

[kelkitli]

Selamlar,
Ziya Hocam çok teşekkür ederim. Sayfa1 de veriden sonra satır boş kalıyor. Boş satırları D17 aralığına göre silemezmiyiz silemezmiyiz.

 

[N.Ziya Hiçdurmaz]

yanıt

Sub tekraredenler()
Dim sat, s As Integer
s = 2
With Sayfa1
    For sat = 26 To 18 Step -1
        If WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) > 1 Then
        Range(.Cells(sat, "a"), .Cells(sat, "g")).Cut Sayfa2.Cells(s, "a")
        s = s + 1
        End If
        If .Cells(sat, "d") = "" Then
        Range(.Cells(sat, "a"), .Cells(sat, "g")).Delete shift:=xlUp
        End If
    Next
End With
End Sub

 

[kelkitli]

Ziya Hocam, güzel oldu da yalnız şöyle bir sorun var:
Bu işlem son dolu satıra kadar yapılmalı. Satır sayısını artırınca da Devreden ve toplam satırlarını da mükerrer kayıt olarak aktarıyor. Bu verilerin hariç tutulması gerekiyor.

 

[kelkitli]

Hocam şu şekilde değiştirdim, "devreden" ve "toplam" değerinide aktardı. Bu değerleri aktarmamalı.

Sub tekraredenler()
Dim sat, s As Integer
s = 2
With Sayfa1
For sat = [B65536].End(3).Row To 18 Step -1
If WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) > 1 Then
Range(.Cells(sat, "a"), .Cells(sat, "g")).Cut Sayfa3.Cells(s, "a")
s = s + 1
End If
If .Cells(sat, "d") = "" Then
Range(.Cells(sat, "a"), .Cells(sat, "g")).Delete shift:=xlUp
End If
Next
End With
Sayfa3.Columns("A:A").ColumnWidth = 8
Sayfa3.Columns("B:B").ColumnWidth = 19.71
Sayfa3.Columns("C:C").ColumnWidth = 61.43
Sayfa3.Columns("D: D").ColumnWidth = 11.57
Sayfa3.Columns("E:E").ColumnWidth = 25.71
Sayfa3.Columns("F:F").ColumnWidth = 12
Sayfa3.Columns("G:G").ColumnWidth = 17
End Sub

 

[kelkitli]

Şu kısımda aşağıdaki gibi bir değişiklik yaptım ama hata veridi. Nasıl hatayı gideririm.

If WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) > 1 And WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) <> "T O P L A M :" And WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) <> "D E V R E D E N :" Then

 

[N.Ziya Hiçdurmaz]

yanıt

Silinmesini istemediğiniz hücrelerin yazı fontunu mavi yapınız.

Sub tekraredenler()
Dim sat, s As Integer
s = 2
With Sayfa1
    For sat = Cells(65536, "b").End(xlUp).Row To 18 Step -1
        If WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) > 1 _
        And Cells(sat, "b").Font.ColorIndex <> 5 Then
        Range(.Cells(sat, "a"), .Cells(sat, "g")).Cut Sayfa2.Cells(s, "a")
        s = s + 1
        End If
        If .Cells(sat, "d") = "" Then
        Range(.Cells(sat, "a"), .Cells(sat, "g")).Delete shift:=xlUp
        End If
    Next
End With
End Sub

 

[kelkitli]

Sağol Ziya Hocam,
Sizi yordum. Hocam bu verileri sistemden alıyorum. Silinmesini istemediğim değerler otomatikman Bold olarak geliyor. Renk yerine bold yazılar silinmesin dedim.
Tamamdır.

Sub tekraredenler()
Dim sat, s As Integer
s = 2
With Sayfa1
For sat = Cells(65536, "b").End(xlUp).Row To 18 Step -1
If WorksheetFunction.CountIf(.Range("b18:b" & sat), .Cells(sat, "b")) > 1 _
And Cells(sat, "b").Font.Bold=False Then
Range(.Cells(sat, "a"), .Cells(sat, "g")).Cut Sayfa2.Cells(s, "a")
s = s + 1
End If
If .Cells(sat, "d") = "" Then
Range(.Cells(sat, "a"), .Cells(sat, "g")).Delete shift:=xlUp
End If
Next
End With
End Sub

 

[N.Ziya Hiçdurmaz]

Sizde sağolun.Sayın kelkitli