benzersiz kayıtları başka sayfada listelemek

[udentr2002]

Merhaba arkadaşlar forumda arama yaptım bir çok konuda buldum yanlız o bulduğum kodları kendi dosyama uyarlayamadım 2 gündürlü uğraşıyorum ama işin içinden çıkamadım. Kısacası yapmaya çalıştığım şu;

Ekli dosyada sayfa1 de bulunan verilerden aynı olanları tekrarsız olarak sayfa2 de a stünuna yazacak ve sayfa1 deki B stünunda (Kodu) bölümünüde yine sayfa2 de B stünuna yazacak, M stünunda (Kalan Miktar) stünundaki değerleride toplayıp (alt toplam) a stünundaki verinin karşısına gelecek Sayfa2 de C stünuna yazacak
ben forumda bulduğum kodlardan bir şey ler yapmaya çalıştım ama olmadı kodları silmeden gönderiyorum belki bir fikir verebilr diye
siz o kodların hepsini silebilrsiniz Şimdiden ilgilenen tüm arkadaşlarıma teşekkür ederim
saygılarımla

 

[Orion1]

Merhaba.
Ekli dosyayı inceleyiniz.
Butona basınız.

 

[veyselemre]

Verilerinizde en alt satırda adı b olan satır da kodu değişik, eğer bu şekilde adı b olan kodu değişik olursa yanlış sonuç verir. O zaman düzeltmek gerekir.

Sub KalanMiktarlar()
    Set S1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s2.Cells.ClearContents
    sons1A = S1.[a65536].End(3).Row
    S1.Range("A3:B" & sons1A & ",M3:M" & sons1A).Copy s2.[a3]
    s2.Select
    Range("A3:B" & sons1A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[F3], Unique:=True
    [c3].Copy [h3]
    sons2F = [F65536].End(3).Row
    With [h4].Resize(sons2F - 3)
        .Formula = "=SUMIF(A$4:A$" & sons1A & ",F4,C$4:C$" & sons1A & ")"
        .Value = .Value
    End With
    [a:e].Delete
End Sub

 

[udentr2002]

orion hocam

zaman ayırıp ilgilendiğiniz için teşekkür ederim. kodlar çalışıyor yanlız belkide ben anlatırken tam olarak anlatamadım
eğer sayfa 1 de tek bir defa yazan bir satır varsa onu göstermiyor benim istediğim eğer sayfa1 de tek bir defa yazılan bir satır varsa onuda sayfa 2 de listelesin
isterseniz gönderdiğniz dosya üzerinden bir deneyin mesala sayfa 1 de en alt satıra tekrarlanmayan sadece bir defa yazılan bir şey yazın kodları çalıştırın göreceksinizki sayfa2 de o bir defa yazılan veri listelenmeyecktir o verininde sayfa 2 de listelenmesi için ne yapabiliriz hocam tekrar ilgilenebilrmisiniz acaba

 

[udentr2002]

veysel hocam

çok teşekkür ederim istediğim gibi olmuş o uyarınız için teşekkür ederim zaten aynı isimle farklı bir kod olmayacak tır benim dosyamda gönderdiğim dosya örnek olması için öyle yazdım gönderdiğniz kodları kullanıyorum çok teşekkür ederim

 

[Recep İpek]

Alternatif olarak aşağıdaki kodları deneyiniz.

Sub AktarTopla()
Dim a, i As Long, b(), n As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
With s1.Range("a3").CurrentRegion.Resize(, 29)
     a = .Value
     ReDim b(1 To UBound(a, 1), 1 To 3)
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 1 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
               n = n + 1
               b(n, 1) = a(i, 1)
               b(n, 2) = a(i, 2)
               .Add a(i, 1), n
          End If
          b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 13)
     Next
End With
With s2.Range("a1")
     .CurrentRegion.ClearContents
     .Resize(n, 3).Value = b
End With
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[udentr2002]

hocam

Öncelikle ilgilenen tüm hocalarıma teşekkür ederim o kodları kendime uyarladım vede kullanıyorum Allah razı olsun
Aynı konuya benzer olduğu için farklı bir konu açıp sormak istemedim
ekli dosyda da göreceğiniz gibi butona tıkaldığımızda sayfa1 deki verilerden a stünundaki isimleri ve M stüunundaki kalan miktarları baz alıp ve sayfa2 deki C stünundaki isimleri ve sayfa2 deki N stünundaki (fiili Miktar) değerleri yukarıdaki aynı mantıkla sayfa 3 de birleştirecek tekrarsız olarak yazacak ve miktarlarınıda alt toplam şeklinde sayfa3 de c stünuna yazacak böyle bir şey yapabilmemiz mümkünmü acaba
Kısacası iki farklı depo var bu iki farklı depoda aynı isimlerde malzemeler kayıtlıdır bu iki depoyu birleştirip bir sayfada tekrarsız olarak listelemek istiyorum
Yanlız dikkat ederseniz sayfa 1 de malzemenin isimleri a stünunda yazılıyken sayfa 2 de c stünunda yazılı ve sayfa1 de malzemenin miktarı m stünunda yazılı iken sayfa 2 de n stünunda yazılı inşallah demek istediğimi anlatabilmişmdir hocam
cevaplarınızı bekleyeceğim sağlıcakla kalın

 

[udentr2002]

özür

dosyayı elemeyi unuttum

 

[Recep İpek]

Alt toplam nasıl olacak? 2 deponun toplamı mı şeklinde mi?

 

[udentr2002]

hocam

iki depoyuda birleştirdikten sonra aynı olan hammaddelerin toplamı şklinde yani her iki depodaki toplamları olacak

 

[veyselemre]

Sub KalanMiktarlar()
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    S3.Cells.ClearContents
    sons1A = S1.[a65536].End(3).Row
    S1.Range("A3:B" & sons1A & ",M3:M" & sons1A).Copy S3.[a3]

    sons2A = S2.[a65536].End(3).Row
    S2.Range("C2:C" & sons2A & ",e2:E" & sons2A & ",N2:N" & sons2A).Copy S3.[a65536].End(3).Offset(1)

    S3.Select
    sons3A = S3.[a65536].End(3).Row
    Range("A3:B" & sons3A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[F3], Unique:=True

    [c3].Copy [h3]
    sons2F = [F65536].End(3).Row
    With [h4].Resize(sons2F - 3)
        .Formula = "=SUMIF(A$4:A$" & sons3A & ",F4,C$4:C$" & sons3A & ")"
        .Value = .Value
    End With
    [a:e].Delete
End Sub

 

[Recep İpek]

Biraz uzun oldu ama boşa gitmesin.

Sub AktarTopla()
Dim a, d, h, i, s, y As Long, b(), c(), e(), n As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
'*****************************************************
With s1.Range("a4").CurrentRegion.Resize(, 29)
     a = .Value
     ReDim b(1 To UBound(a, 1), 1 To 3)
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 2 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
               n = n + 1
               b(n, 1) = a(i, 1)
               b(n, 2) = a(i, 2)
               .Add a(i, 1), n
          End If
          b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 13)
     Next
End With
'*****************************************************
With s2.Range("a2").CurrentRegion.Resize(, 22)
     d = .Value
     ReDim c(1 To UBound(d, 1), 1 To 3)
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 2 To UBound(d, 1)
          If Not .exists(d(i, 3)) Then
               h = h + 1
               c(h, 1) = d(i, 3)
               c(h, 2) = d(i, 5)
               .Add d(i, 3), h
          End If
          c(.Item(d(i, 3)), 3) = c(.Item(d(i, 3)), 3) + d(i, 14)
     Next
End With
'*****************************************************
s3.Range("a2:c100").ClearContents
s3.Cells(2, 1).Resize(n, 3).Value = b
s3.Cells(n + 2, 1).Resize(h, 3).Value = c
'*****************************************************
With s3.Range("a2").CurrentRegion.Resize(, 3)
     s = .Value
     ReDim e(1 To UBound(s, 1), 1 To 3)
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 2 To UBound(s, 1)
          If Not .exists(s(i, 1)) Then
               y = y + 1
               e(y, 1) = s(i, 1)
               e(y, 2) = s(i, 2)
               .Add s(i, 1), y
          End If
          e(.Item(s(i, 1)), 3) = e(.Item(s(i, 1)), 3) + s(i, 3)
     Next
End With
'*****************************************************
s3.Range("a2:c100").ClearContents
s3.Cells(2, 1).Resize(y, 3).Value = e
'*****************************************************
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[udentr2002]

çok ama çok teşekkür ederim Her ikinizdende Allah razı olsun
Her zaman en iyisi kısa olanı kullanmaktır sanırım ama hocam çok emek verdiğiniz belli o kodlar için Çok teşekkür ederim hakkınızı helal edin

 

[veyselemre]

Sayın Ripek'in yaptığı yöntemi de biraz kısaltalım.

Sub AktarTopla()
Dim a, i As Long, n As Long
    Set dic = CreateObject("Scripting.Dictionary")
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("sayfa2")
    Set s3 = Sheets("sayfa3")
    ReDim b(1 To 3, 1 To 1)

    a = s1.Range("a3").CurrentRegion.Resize(, 29).Value
    ad = 1: kod = 2: miktar = 13
    GoSub islem

    a = s2.Range("C2:N" & s2.[a65536].End(3).Row).Value
    ad = 1: kod = 3: miktar = 12
    GoSub islem

    ReDim Preserve b(1 To 3, 1 To UBound(b, 2) - 1)
    With s3.Range("a3")
        .CurrentRegion.ClearContents
        .Resize(n, 3).Value = WorksheetFunction.Transpose(b)
    End With
    Set s1 = Nothing
    Set s2 = Nothing
    Set s3 = Nothing
    Set dic = Nothing
    Erase a
    Erase b
    MsgBox "Bitti"
    Exit Sub
islem:
    With dic
        .CompareMode = vbTextCompare
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1
                b(1, n) = a(i, ad)
                b(2, n) = a(i, kod)
                .Add a(i, ad), n
                ReDim Preserve b(1 To 3, 1 To UBound(b, 2) + 1)
            End If
            b(3, .Item(a(i, ad))) = b(3, .Item(a(i, ad))) + a(i, miktar)
        Next
    End With
    Return
End Sub

 

[udentr2002]

sn veyselemre hocam

11 nolu mesajınızdaki kodları kullanıyorum yanlız ekde gönderdiğim dosyada sayfa1 de B stünunda (Kodu) bölümünde göreceksiniz bazı kodlar A ile başlıyor (A2S0002) gibi sayfa 3 e sayfa1 ve sayfa 2 deki benzersiz kayıtları süzüp alt toplamlarını aldıktan sonra Sayfa3 de B stünunda yukarıda bahsettiğim A ile başlayan kodların olduğu satırı komple silebilmesi için nasıl bir kod eklememiz lazım

 

[veyselemre]

Aşağıdaki gibi bahsettiğiniz satırları silebilirsiniz. Ama bu sistem yanlış gibi geliyor. Örneğin Adı a olanın kodu hem H10001 hem H21001 de bu şekilde olduğu zaman sayfa 3 te kalan miktarı 2958,, oluyor, halbuki sayfa1 ve sayfa2 de kalan miktarların toplamı 1092,, bir tutarsızlık oluşuyor. Bu yüzden ya sadece adı kriter olarak kullanılacak yada kodlar da tutarlı olacak.

Sub KalanMiktarlar()
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    S3.Cells.ClearContents
    sons1A = S1.[a65536].End(3).Row
    S1.Range("A3:B" & sons1A & ",M3:M" & sons1A).Copy S3.[a3]

    sons2A = S2.[a65536].End(3).Row
    S2.Range("C2:C" & sons2A & ",e2:E" & sons2A & ",N2:N" & sons2A).Copy S3.[a65536].End(3).Offset(1)

    S3.Select
    sons3A = S3.[a65536].End(3).Row
    Range("A3:B" & sons3A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[F3], Unique:=True

    [c3].Copy [h3]
    sons2F = [F65536].End(3).Row
    With [h4].Resize(sons2F - 3)
        .Formula = "=SUMIF(A$4:A$" & sons3A & ",F4,C$4:C$" & sons3A & ")"
        .Value = .Value
    End With
    [a:e].Delete

    Dim rForDelete As Range
    Dim c As Range
    With S3
        For Each c In Range(.[b4], .[b65536].End(3))
            If c.Value Like "A*" Then
                If Not rForDelete Is Nothing Then
                    Set rForDelete = Union(rForDelete, c)
                Else
                    Set rForDelete = c
                End If
            End If
        Next
        If Not rForDelete Is Nothing Then rForDelete.EntireRow.Delete (xlUp)
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
End Sub

 

[udentr2002]

Veysel Hocam

Çok teşekkür ederim haklısınız ama örnek dosya hazırlarken öylesine dikkat etmeden girdiğim için kodlarda tutarsızlık varmış gibi görünüyor gerçek dosyada hiç bir kod aynı isimle iki hammaddenin ismi ile girilmiyor bu nedenle gönderdiğiniz kod işime yarayacaktır çok sağolun