İki ayrı sayfadaki isim listesini tek liste haline getirmek

[Mdemir63]

Selamlar,
Arkadaşlar ekteki dosyamda anlatmaya çalıştım.

Saygılar

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz komutanım.

Sub Karsilastir()
Dim i, j, Son As Long
Dim c As Range
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
s3.Select
[A2:B65536].ClearContents
Son = s2.[A65536].End(3)
j = 1
Application.ScreenUpdating = False
For i = 2 To s1.[A65536].End(3).Row
    With s2.Range("B2:B" & Son)
        Set c = .Find(s1.Cells(i, "B"), LookIn:=xlValues)
        If Not c Is Nothing Then
            j = j + 1
            Cells(j, "A") = j - 1
            Cells(j, "B") = s1.Cells(i, "B")
        End If
    End With
Next i
Application.ScreenUpdating = True
msgbox "İşlem Tamamdır...:")
End Sub

 

[metinozlu]

çözüm ekte

 

[Mdemir63]

Merhaba,

Aşağıdaki kodları dener misiniz komutanım.

Sub Karsilastir()
Dim i, j, Son As Long
Dim c As Range
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
s3.Select
[A2:B65536].ClearContents
Son = s2.[A65536].End(3)
j = 1
Application.ScreenUpdating = False
For i = 2 To s1.[A65536].End(3).Row
    With s2.Range("B2:B" & Son)
        Set c = .Find(s1.Cells(i, "B"), LookIn:=xlValues)
        If Not c Is Nothing Then
            j = j + 1
            Cells(j, "A") = j - 1
            Cells(j, "B") = s1.Cells(i, "B")
        End If
    End With
Next i
Application.ScreenUpdating = True
msgbox "İşlem Tamamdır...:")
End Sub

Selamlar,
Necdet abi nasıl 100 kişilik listeler 48 kişiye düşüyor . Ben anlatamadım abi galiba. Bir defa 100 kişilik liste olacak artı diğer sayfadaki listeden de ilk sayfada aynı isim olanlar ayıklandıktan sonra o iki liste birleştirilecek.

Saygılar abi

 

[Necdet]

Merhaba,

Ben sorunuzdan öyle anlamadım ki. Bir kişi her iki sayfada varsa onları yazsın olarak anladım.

Bu durumda Metin Özlü arkadaşımız doğru anlamış oluyor sanırım.

 

[Mdemir63]

Merhaba,

Ben sorunuzdan öyle anlamadım ki. Bir kişi her iki sayfada varsa onları yazsın olarak anladım.

Bu durumda Metin Özlü arkadaşımız doğru anlamış oluyor sanırım.

Selamlar,
Necdet abi, Metin Özlü arkadaşımız çok sağolsun ama ben özet tablo ile değil, Ya makro ile ya da fonksiyonla nasıl yapabilirim.

Saygılar

Not: Metin Özlü arkadaşımıza ayrıca teşekkür ederim.

 

[Mdemir63]

Selamlar,

Arkadaşlar bu konuda bilgisi olanlar lütfen paylaşırlarsa çok memnun olurum.

Saygılar

 

[Ömer]

Yanlış anlamışım düzeltip ekliyorum..

.

 

[Ömer]

Merhaba,

Fonksiyonla yapabildim. Örnek dosyayı incelermisiniz. İstediğiniz bu mu?

.

 

[Necdet]

Merhaba,

Bende yavaştan yavaştan bu konuya bakıyordum. Hangi yöntemi seçeyim diye, o yüzden geç kaldım.

Sub Karsilastir()
Dim i, j As Long
Dim c As Range
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
Application.ScreenUpdating = False
s3.Select
[A2:B65536].ClearContents
s1.Range("B2:B" & s1.[B65536].End(3).Row).Copy [B2]
Son = [B65536].End(3).Row
j = Son
For i = 2 To s2.[A65536].End(3).Row
    With Range("B2:B" & Son)
        Set c = .Find(s2.Cells(i, "B"), LookIn:=xlValues)
        If c Is Nothing Then
            j = j + 1
            Cells(j, "B") = s2.Cells(i, "B")
        End If
    End With
Next i
[A2] = 1
Range("A2:A" & [B65536].End(3).Row).DataSeries _
                Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                Step:=1, Trend:=False
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır..."
End Sub

 

[Necdet]

İki ayrı sonuca ulaşmışız

 

[Mdemir63]

Selamlar,

Necdet abi çok teşekkür ederim.Ellerine, emeğine sağlık.

espiyonajl hocam sizede çok teşekkür ederim.Ellerine, emeğine sağlık.

Yalnız bir şey var, necdet abinin yaptığı makro 150 kişi aktarmış,
hocam sizin fonksiyonlarla yaptığınız 152 kişi aktarmış. Çok özür dilerim sonuç bence 150 olmalı. Bakabilirmisiniz?

Saygılar sunuyorum. İyiki varsınız

 

[Ömer]

Selamlar,

Necdet abi çok teşekkür ederim.Ellerine, emeğine sağlık.

espiyonajl hocam sizede çok teşekkür ederim.Ellerine, emeğine sağlık.

Yalnız bir şey var, necdet abinin yaptığı makro 150 kişi aktarmış,
hocam sizin fonksiyonlarla yaptığınız 152 kişi aktarmış. Çok özür dilerim sonuç bence 150 olmalı. Bakabilirmisiniz?

Saygılar sunuyorum. İyiki varsınız

Bazı isimlerin sonunda ünvan olduğu için, isimleri farklı algılayarak aktarmış. Bunu bende yeni farkettim. 9. mesajdaki dosyayı yeniledim, tekrar incelermisiniz..

.

 

[Mdemir63]

Bazı isimlerin sonunda ünvan olduğu için, isimleri farklı algılayarak aktarmış. Bunu bende yeni farkettim. 9. mesajdaki dosyayı yeniledim, tekrar incelermisiniz..

.

Selamlar,

Hocam teşekkür ederim yordum sizleri

Saygılar

 

[Mdemir63]

Selamlar,

Ayrı başlık açmamak için burada açıklamak istedim. Eğer bir sütunda isim listesi olduğunu kabul edersek; Bu listede aynı isimler mükerrer var ise bunu nasıl sadeleştirebiliriz?

Saygılar


Ek dosya da gibi

 

[Orion1]

Selamlar,

Ayrı başlık açmamak için burada açıklamak istedim. Eğer bir sütunda isim listesi olduğunu kabul edersek; Bu listede aynı isimler mükerrer var ise bunu nasıl sadeleştirebiliriz?

Saygılar


Ek dosya da gibi

C sütununda mükerrer olmayan kayıtları listeler.

Sub mukerrer()
Dim sat As Long, i As Long
Range("C2:C65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "B").End(xlUp).Row
    If WorksheetFunction.CountIf(Range("A2:A" & i), Cells(i, "A").Value) = 1 Then
        Cells(sat, "C").Value = Cells(i, "B").Value
        sat = sat + 1
    End If
Next i
MsgBox "işlem tamam"
End Sub

 

[Mdemir63]

C sütununda mükerrer olmayan kayıtları listeler.

Sub mukerrer()
Dim sat As Long, i As Long
Range("C2:C65536").ClearContents
sat = 2
For i = 2 To Cells(65536, "B").End(xlUp).Row
    If WorksheetFunction.CountIf(Range("A2:A" & i), Cells(i, "A").Value) = 1 Then
        Cells(sat, "C").Value = Cells(i, "B").Value
        sat = sat + 1
    End If
Next i
MsgBox "işlem tamam"
End Sub

Selamlar,
Hocam mükerrer olanları da listeliyor.

Saygılar

 

[Necdet]

Merhaba,

Gelişmiş Süz ile yapılmışını dener misiniz Komutanım.

Sub Macro1()
    Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "E1"), Unique:=True
End Sub

 

[Mdemir63]

Merhaba,

Gelişmiş Süz ile yapılmışını dener misiniz Komutanım.

Sub Macro1()
    Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "E1"), Unique:=True
End Sub

[/quote

Selamlar,

Teşekkürler Necdet abi

Saygılar

 

[Necdet]

Selam,

Saygı benden