Diğer Sayfadaki Benzersizleri Bul ve Listele

[sekhil]

Merhabalar,

Sayfa1 deki A sütundaki verileri sayfa2 de H sütununa benzersiz olarak otomatik olarak yazsın-listelesin istiyorum.


böyle bir kod buldum forumda çalışıyor fakat aynı sayfada listeneliyor.
Not:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or Intersect(s1.Target, [H:H]) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("E:E"), Target) = 0 Then
Range("E" & Cells(Rows.Count, "E").End(3).Row + 1).Value = Target.Value
End If
End Sub

 

[Ömer]

Merhaba,

Sayfa2 nin kod bölümüne kopyalayınız.

Private Sub Worksheet_Activate()

    Dim S1 As Worksheet, d As Object, i As Long, deg
    
    Set S1 = Sheets("Sayfa1")
    Set d = CreateObject("Scripting.Dictionary")
        
    Application.ScreenUpdating = False

    For i = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        deg = S1.Cells(i, "A")
        If deg <> "" Then
            If Not d.exists(deg) Then
                d.Add deg, Nothing
            End If
        End If
    Next i

    Range("H2:H" & Rows.Count).ClearContents
    Range("H2").Resize(d.Count) = Application.Transpose(d.Keys)

End Sub

 

[sekhil]

hocam çok ama çok teşekkür ederim

 

[Korhan Ayhan]

Alternatif;

2007 ve sonraki sürümler için çalışır.

Option Explicit

Private Sub Worksheet_Activate()
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Range("A2:A" & Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row).Copy Range("H2")
    Range("H2:H" & Cells(Rows.Count, 8).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True
End Sub

 

[sekhil]

hocam peki sayfa1 'den 2 farklı sütunu alıp, sayfa2 deki iki farklı sütuna nasıl eklerim

Örnerğin: Sayfa1de bulunan A ve B sütundaki verileri, Sayfa2'deki D ve E sütununa otomatik olarak getirsin istiyorum

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub Worksheet_Activate()
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Range("A2:B" & Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row).Copy Range("D2")
    Range("D2:E" & Cells(Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    Application.ScreenUpdating = True
End Sub

 

[sekhil]

Korhan Hocam sayfa kendini otomatik olarak update etsin istiyorum . bu şekilde olunca manuel olarak sayfalar arasından elle geçiş yapınca veriler diğer sayfaya geliyor
Application.ScreenUpdating = False

bunu True yaptım ama değişen bişey olmadı

 

[Korhan Ayhan]

Makronun çalışması için bir olayın olması gerekiyor.

En mantıklı gibi görünen Sayfa2'nin aktif olma durumunu kullanmıştık. Sonuçta siz sonuçları görmek için Sayfa2'yi açıyorsunuz. Bu olay mantıklı gibi gelmişti. Ama demek ki size uymadı.

Örnek olarak Sayfa1 isimli sayfada A-B sütunlarına veri girişi yaptığınızda bu işlem yapılabilir.

Sayfa1 isimli sayfanızın kod bölümüne uygulayıp deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    S1.Range("A2:B" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Copy S2.Range("D2")
    S2.Range("D2:E" & S2.Cells(S2.Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    Application.ScreenUpdating = True

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[sekhil]

Korhan Hocam Emegnize sağlık
Bunu sayfa 1 e ekliyorum yalnız kolonlarımı bir türlü ayarlayamıyorum

Sayfa 2'deki D sütunumdan Sayfa 1'deki C sütunuma benzersiz olanları aktarmak için nasıl düzenleyebilirim
teşekkürler

 

[Korhan Ayhan]

Bu mesajınızda sayfalar yer değiştirmiş..

Deneyiniz.

Sayfa2'nin kod bölümüne uygulayınız.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet

    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")

    Application.ScreenUpdating = False
    S2.Range("D2:D" & S2.Cells(S2.Rows.Count, 4).End(3).Row).Copy S1.Range("C2")
    S1.Range("C2:C" & S1.Cells(S1.Rows.Count, 3).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[sekhil]

Korhan Hocam teşekkürler yalnız bu kodlar ile yalnızca tek bir sütundaki verileri alıyor. D sütununda bulunan diğerlerini aktarmıyor?
bu kodum çalışıyor fakat kendi kendini güncellemiyor dediğim gibi
Private Sub Worksheet_Activate()

Dim S1 As Worksheet, d As Object, i As Long, deg

Set S1 = Sheets("StokGirisleri")
Set d = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = False

For i = 2 To S1.Cells(Rows.Count, "D").End(xlUp).Row
deg = S1.Cells(i, "D")
If deg <> "" Then
If Not d.exists(deg) Then
d.Add deg, Nothing
End If
End If
Next i

Range("C2:C" & Rows.Count).ClearContents
Range("C2").Resize(d.Count) = Application.Transpose(d.Keys)

End Sub

 

[Korhan Ayhan]

Sorunuz bu değil miydi?

Sayfa 2'deki D sütunumdan Sayfa 1'deki C sütunuma benzersiz olanları aktarmak için nasıl düzenleyebilirim

 

[sekhil]

evet hocam sorum bu aynıdır. en son vermiş olduğunuz kod ile de kendi otomatik olarak güncellesin diye vermiştiniz. güncelliyor fakat sayfa1 deki benzersizlerin yanlızca 1tanesini sayfa 2de listeliyor

 

[sekhil]

hocam exceli kapattım açtım sorun düzeldi tşeekkür ederim

 

[sekhil]

hocam şimdi yine kapattım açtım tek bir benzersiz listelemiş diğerleri silinmiş

 

[Korhan Ayhan]

Örnek dosya paylaşınız.

 

[sekhil]

Buyrun hocam örnek dosya ektedir.

Not: Yapmak istediğim "Stok Girişleri"nde sayfamdaki ürün kodlarını benzersiz olarak "ürünler" sayfamda listeletmek istiyorum.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet

    Set S1 = Sheets("Urunler")
    Set S2 = Sheets("StokGirisleri")

    Application.ScreenUpdating = False
    S1.Range("C2:C" & S1.Rows.Count).ClearContents
    S2.Range("D2:D" & S2.Cells(S2.Rows.Count, 4).End(3).Row).Copy S1.Range("C2")
    S1.Range("C2:C" & S1.Cells(S1.Rows.Count, 3).End(3).Row).RemoveDuplicates Columns:=3, Header:=xlNo
    Application.ScreenUpdating = True

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[sekhil]

hocam çok teşekkürler oldu

 

[sekhil]

Korhan Hocam "StokGirisleri" sayfasında ürün kodu sildiğimde "Urunler" sayfasında sildiğim kod duruyor sildiğimde oradaki satırdaki kayıtta silinebilirmi?