• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Sütundaki Aynı Kayıtları Bulma

M

mozturk6

Katılım
6 Ağustos 2010
Mesajlar
8
Excel Vers. ve Dili
2003
Ben aşağıdaki arşivimdeki imaj numaralarını A Sütununa yazacağım.
379290
476889
261214
221713
253379
261214
379290

Excel Dosyasından İstediğim bu kayıtlardaki aynı numaraları bulup B Sütununa yazması.
379290
261214

Saygılarımla.
 
Aşağıdaki kodlar işinizi görecektir.:cool:
Kod: 
Option Base 1
Sub mukerereler_59()
Dim hcr As Range, sat As Long, myarr(), a As Long
Sheets("Sayfa1").Select
Range("B:B").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
ReDim myarr(1 To 1, 1 To 65536)
For Each hcr In Range("A1:A" & sat)
    If WorksheetFunction.CountIf(Range("A1:A" & hcr.Row), hcr.Value) = 1 Then
        If WorksheetFunction.CountIf(Range("A1:A" & sat), hcr.Value) > 1 Then
            a = a + 1
            myarr(1, a) = hcr.Value
        End If
    End If
Next
If a > 0 Then
    Application.ScreenUpdating = False
    ReDim Preserve myarr(1 To 1, 1 To a)
    Range("B1").Resize(a, 1) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "Benzer kayıtlar çıkarıldı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
End Sub
 
Yardımlarınızdan dolayı teşekkür ederim.

Evren bey verdiğiniz kodu nasıl ekleyeceğimi bilmiyorum. Excel hiç kullanmadım.
Ali bey sizin verdiğiniz dosyadada rakamları kenarlara yazmadı hangi sütun olduğunu gösteriyor.

Teşekkür ederim.
 
mozturk6' Alıntı:
Ben aşağıdaki arşivimdeki imaj numaralarını A Sütununa yazacağım.
379290
476889
261214
221713
253379
261214
379290

Excel Dosyasından İstediğim bu kayıtlardaki aynı numaraları bulup B Sütununa yazması.
379290
261214

Saygılarımla.
Genişletmek için tıkla ...

.

Alternatif.

.
 

Ekli dosyalar

Yurttaş arkadaşım yazdığın dosya tamam ama satır sayısını sonsuz yapabilir misin?
Mesela şu an 30.000 satırda arama yapacağım. İleride daha da fazla olacak?

Saygılarımla.
Teşekkürler.
 
mozturk6' Alıntı:
Yurttaş arkadaşım yazdığın dosya tamam ama satır sayısını sonsuz yapabilir misin?
Mesela şu an 30.000 satırda arama yapacağım. İleride daha da fazla olacak?

Saygılarımla.
Teşekkürler.
Genişletmek için tıkla ...

.

Arkadaşım , Excelde sonsuz satır var mı? Yani bir şey sorarken sorulan soruda bir mantık olmalı. Değil mi?


Ne demek? Satır sayısını sonsuz yapabilir misin? Ben sihirbaz değilim.

7 satırlık bir örnek vererek, sonsuz satır istemekte ayrı bir konu...

Öte yandan, aralık sonlarını 30000 veya kaç satırı kapsayacaksa o kadar belirlersiniz. Bu bir maharet gerektirmiyor. Bunu siz de yapabilirsiniz. Ancak bu şekildeki bir uygulama ile Excel kasılır.

Bu nedenle, size önerilen makroyu kullanın. Bu daha uygundur.


.
 
Sınırsız derken 7 satırla sınırlandırmayalım diye anlatmak istemiştim yanlış anlatmıştım çok özür diliyorum. Ben excel'i hiç kullanmayı bilmediğim için nasıl yapılacağını anlatabilirsen yapmaya çalışayım.

Yardımlarınızdan dolayı çok teşekkür ederim.
 
Sınırsız derken 7 satırla sınırlandırmayalım diye anlatmak istemiştim yanlış anlatmıştım çok özür diliyorum. Ben excel'i hiç kullanmayı bilmediğim için nasıl yapılacağını anlatabilirsen yapmaya çalışayım.

Yardımlarınızdan dolayı çok teşekkür ederim. Örnekteki gibi bir buton aracılığı ile de olabilir.
 

Ekli dosyalar

30 bin kayıt formülle yaparsanız kasar.
Ben makroyu düzenleyip dosyanıza ekledim ve bir butona atadım.
A ve B sütunlarında bulunan mükerrer kayıtları d sütununa listeler.
Kod: 
Option Base 1
Sub mukerereler_59()
Dim hcr As Range, sat As Long, myarr(), a As Long, i As Byte
Dim adr As String
Sheets("Sayfa1").Select
Range("D:D").ClearContents
ReDim myarr(1 To 1, 1 To 65536)
For i = 1 To 2
    sat = Cells(65536, i).End(xlUp).Row
    adr = Range(Cells(2, i), Cells(sat, i)).Address
    For Each hcr In Range(adr)
        If hcr.Value <> "" Then
            If WorksheetFunction.CountIf(Range(Cells(2, i), Cells(hcr.Row, i)), hcr.Value) = 1 Then
                If WorksheetFunction.CountIf(Range(adr), hcr.Value) > 1 Then
                    a = a + 1
                    myarr(1, a) = hcr.Value
                End If
            End If
        End If
    Next
Next i
If a > 0 Then
    Application.ScreenUpdating = False
    ReDim Preserve myarr(1 To 1, 1 To a)
    Range("D2").Resize(a, 1) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "Benzer kayıtlar çıkarıldı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
End Sub
 

Ekli dosyalar

Evren bey çok teşekkür ederim. Tam istediğim gibi oldu. Bütün yardımcı olan arkadaşlarımı çok sağolun.
 
Özür dileyerek bir soru sormak istiyorum dosya 2003'de çalışıyor fakat 2007'de uyarı verdi. Muhtemelen bir yeri açmam gerekiyor ama bulamadım. Hata mesajı "Bu çalışma kitabı VBA projesi, ActiveX denetimleri ve programlanabilirlikle ilgili diğer özelliklerini kaybetti." şu şekilde. Yardımını bekliyorum.
 
mozturk6' Alıntı:
Özür dileyerek bir soru sormak istiyorum dosya 2003'de çalışıyor fakat 2007'de uyarı verdi. Muhtemelen bir yeri açmam gerekiyor ama bulamadım. Hata mesajı "Bu çalışma kitabı VBA projesi, ActiveX denetimleri ve programlanabilirlikle ilgili diğer özelliklerini kaybetti." şu şekilde. Yardımını bekliyorum.
Genişletmek için tıkla ...

merhaba
office 2007'de makro içerebilen çalışma kitabını seçerek kayıt ediniz. makrolu dosyanız bu şekilde çalışacaktır.
 
Orion1' Alıntı:
30 bin kayıt formülle yaparsanız kasar.
Ben makroyu düzenleyip dosyanıza ekledim ve bir butona atadım.
A ve B sütunlarında bulunan mükerrer kayıtları d sütununa listeler.
Kod: 
Option Base 1
Sub mukerereler_59()
Dim hcr As Range, sat As Long, myarr(), a As Long, i As Byte
Dim adr As String
Sheets("Sayfa1").Select
Range("D:D").ClearContents
ReDim myarr(1 To 1, 1 To 65536)
For i = 1 To 2
    sat = Cells(65536, i).End(xlUp).Row
    adr = Range(Cells(2, i), Cells(sat, i)).Address
    For Each hcr In Range(adr)
        If hcr.Value <> "" Then
            If WorksheetFunction.CountIf(Range(Cells(2, i), Cells(hcr.Row, i)), hcr.Value) = 1 Then
                If WorksheetFunction.CountIf(Range(adr), hcr.Value) > 1 Then
                    a = a + 1
                    myarr(1, a) = hcr.Value
                End If
            End If
        End If
    Next
Next i
If a > 0 Then
    Application.ScreenUpdating = False
    ReDim Preserve myarr(1 To 1, 1 To a)
    Range("D2").Resize(a, 1) = Application.Transpose(myarr)
    Application.ScreenUpdating = True
    MsgBox "Benzer kayıtlar çıkarıldı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
End Sub
Genişletmek için tıkla ...



Bu işime yaradı, teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst