• DİKKAT

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

Diğer Sayfadaki Benzersizleri Bul ve Listele

  • Konbuyu başlatan Konbuyu başlatan sekhil
  • Başlangıç tarihi Başlangıç tarihi
S

sekhil

Katılım
16 Eylül 2012
Mesajlar
49
Excel Vers. ve Dili
excell 2010
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
 
Merhaba,

Sayfa2 nin kod bölümüne kopyalayınız.
Kod: 
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
 
Alternatif;

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

C++: 
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
 
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
 
Deneyiniz.

C++: 
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
 
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ı
 
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.

C++: 
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
 
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
 
Bu mesajınızda sayfalar yer değiştirmiş..

Deneyiniz.

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

C++: 
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
 
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
 
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
Genişletmek için tıkla ...
 
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
 
hocam exceli kapattım açtım sorun düzeldi tşeekkür ederim
 
hocam şimdi yine kapattım açtım tek bir benzersiz listelemiş diğerleri silinmiş :(
 
Örnek dosya paylaşınız.
 
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.
 

Ekli dosyalar

Deneyiniz.

C++: 
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
 
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?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst