Mükerrer Bilgileri Bul/Aktar,

[Utekiner]

Selam,

Ekte göndermiş olduğum excel çalışmasında A sütunundaki mükerrer olan verileri yeni bir sheet oluşturup satıra ait tüm bilgilerini aktarmak için destek olur musunuz. Satır sayısı 15.000 veri mevcut.

Örnek Dosya

 

[Muzaffer Ali]

Aleyküm selam.
Örneğe bakılırsa bütün Malzeme Adlarının mükerrer kayıtları var. Buna göre bütün sayfadaki kayıtlar yeni sayfaya aktarılacak.

 

[Utekiner]

Aleyküm selam.
Örneğe bakılırsa bütün Malzeme Adlarının mükerrer kayıtları var. Buna göre bütün sayfadaki kayıtlar yeni sayfaya aktarılacak.

Merhaba;
Yeni sayfaya mükerrer olan malzeme no ve bilgilerinin aktarılması (Veriler aynı olacağından dolayı bir adet veri aktarması yeterli) ve mümkünse kaç adet olduğunu aktarabilir miyiz. Yardımcı olur musunuz.

 

[Muzaffer Ali]

Veri tabı / Veri Araçları / Yinelenenleri kaldır menüsünü denediniz mi?

Daha sonra aynı kayıttan kaç tane olduğu sayılabilir.

 

[Muzaffer Ali]

Mutlaka kod ile yapmak isterseniz aşağıdaki kodu bir module kopyalayıp çalıştırın.

Sub Test()
    Dim syf As Worksheet
    Dim Bak As Integer
    Dim Say As Integer
    Sheets("Sheet1").Copy Before:=Sheets(1)
    With ActiveSheet
        .Range("A:B").RemoveDuplicates Columns:=2, Header:=xlYes
        Say = .Cells(Rows.Count, "A").End(xlUp).Row
        For Bak = 2 To Say
            .Cells(Bak, "A") = Bak - 1
            .Cells(Bak, "C") = WorksheetFunction.CountIf(Sheets("Sheet1").Range("B:B"), .Cells(Bak, "B"))
        Next
    End With
End Sub

 

[wezyr]

Amatörce şöyle çözebildim ustalar daha iyi çözümlerde sunabilir.

Book1.xlsm dosyasını indir - download

Book1.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[Utekiner]

Mutlaka kod ile yapmak isterseniz aşağıdaki kodu bir module kopyalayıp çalıştırın.

Sub Test()
    Dim syf As Worksheet
    Dim Bak As Integer
    Dim Say As Integer
    Sheets("Sheet1").Copy Before:=Sheets(1)
    With ActiveSheet
        .Range("A:B").RemoveDuplicates Columns:=2, Header:=xlYes
        Say = .Cells(Rows.Count, "A").End(xlUp).Row
        For Bak = 2 To Say
            .Cells(Bak, "A") = Bak - 1
            .Cells(Bak, "C") = WorksheetFunction.CountIf(Sheets("Sheet1").Range("B:B"), .Cells(Bak, "B"))
        Next
    End With
End Sub

Hocam öncelikte çok teşekkür ederim vaktinizi ayırıp kod paylaştığınız için. A sütunundaki "No" değerinin mükerrer olanları raporlamak için kodun hangi bölümlerinde değişiklik yapmalıyım. No (A sütununu) farklı bir sayfada raporlamam gerekti. Destek olabilir misiniz.

 

[Muzaffer Ali]

Aşağıdaki şekilde olmalı.

Sub Test()
    Dim syf As Worksheet
    Dim Bak As Integer
    Dim Say As Integer
    Sheets("Sheet1").Copy Before:=Sheets(1)
    With ActiveSheet
        .Range("A:B").RemoveDuplicates Columns:=1, Header:=xlYes
        Say = .Cells(Rows.Count, "A").End(xlUp).Row
        For Bak = 2 To Say
            .Cells(Bak, "C") = WorksheetFunction.CountIf(Sheets("Sheet1").Range("A:A"), .Cells(Bak, "A"))
        Next
    End With
End Sub

 

[Utekiner]

Elinize sağlık teşekkür ederim. Yordum sizi @dalgalikur