Hücredeki Değerler Aynıysa Toplama

[sarman61]

Ekteki tabloda görebileceğiniz gibi 1. sayfadaki malzeme sipariş listesinde kodları aynı olan ürünlerin yanlarındaki adetleri toplayarak sayfa2'ye aktararak aynı ürünleri bir satıra düşürmek istiyorum.Ekteki dosyada ne demek istediğimi anlayabilirsiniz.

Yardımlarınız için şimdiden teşekkürler...

 

[Necdet]

Merhaba,

Fonksiyon ya da makro kullanmadan yapmanız olası.

Özet Tabloyu kullanabilirsiniz.

Değerleri Özet Tablodan kurtarmak isterseniz Özet Tablonun olduğu sütünları Kopyala - Özel Yapıştır - Değerler ile Özet Tablodan kurtarabilirsiniz.

 

[sarman61]

Evet buda işimi kısmen görüyor ancak sayfa1'e yeni bir kayıt eklediğimde bunu özet tabloya nasıl ekletebilirim var olan malzeme kodları üzerinde güncelleme yapabiliyorum ancak yeni ürün geldiğinde nasıl yapabilirim?

 

[İhsan Tank]

Evet buda işimi kısmen görüyor ancak sayfa1'e yeni bir kayıt eklediğimde bunu özet tabloya nasıl ekletebilirim var olan malzeme kodları üzerinde güncelleme yapabiliyorum ancak yeni ürün geldiğinde nasıl yapabilirim?

merhaba
boş bir module kopyalarak deneyiniz

Sub tekle_topla()
Dim a As Long
Dim b As Long
asi = MsgBox("Verileri Tek'e Düşürüp Topluyayım Mı_?", vbYesNo, "Onay")
If asi = vbNo Then Exit Sub
a = Cells(65536, "A").End(xlUp).Row
Sheets("Sayfa2").Range("A2:D" & a).ClearContents
sat = 2
son = Worksheets("Sayfa1").Cells(Rows.Count, "A").End(3).Row
For r = 2 To son
aranan1 = Sheets("Sayfa1").Cells(r, "A").Value
If Sheets("Sayfa1").Cells(r, "A").Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("Sayfa1").Range("A2:A" & r), aranan1) = 1 Then
Sheets("Sayfa2").Cells(sat, "A").Value = Sheets("Sayfa1").Cells(r, "A").Value
sat = sat + 1
End If
End If
Next r
For b = 2 To a
Cells(b, "B") = WorksheetFunction.VLookup(Range("A" & b), Sheets("Sayfa1").Range("A2:D65536"), 2, 0)
Cells(b, "C") = WorksheetFunction.VLookup(Range("A" & b), Sheets("Sayfa1").Range("A2:D65536"), 3, 0)
Cells(b, "D") = WorksheetFunction.SumIf(Sheets("Sayfa1").Range("A2:A65536"), Range("A" & b), Sheets("Sayfa1").Range("D2:D65536"))
Next
MsgBox "Veriler Tek'e Düşürüldü ve Toplandı", vbInformation, "Bitiş"
End Sub

 

[sarman61]

Kopyalaıp çalıştırıyorum ancak 2 sayfaya sadece ürünkodları geliyor adet toplamalarını 1.sayfadaki adetler üzerinde yapıyor ve yanlış toplama yapıyor ?

 

[İhsan Tank]

Kopyalaıp çalıştırıyorum ancak 2 sayfaya sadece ürünkodları geliyor adet toplamalarını 1.sayfadaki adetler üzerinde yapıyor ve yanlış toplama yapıyor ?

eki inceleyin

 

[sarman61]

Necdet hocam sizinde elinize sağlık özet tabloda çalışıyordu...

İhsan hocam elinize sağlık çok teşekkürler tam istediğim şekil olmuş...

Ancak yeni kod eklediğimde sadece 2.sayfa'ya ürün kodu gelmektedir adı ve adetleri gelmiyor ?

 

[sarman61]

Ancak yeni kod eklediğimde sadece 2.sayfa'ya ürün kodu gelmektedir adı ve adetleri gelmiyor ?

 

[İhsan Tank]

üstteki dosyamı yeniledim ve ben deniyorum yeni ürünleri ekliyor.

 

[Necdet]

Merhaba,

Alternatif olsun, hızlı çalışacağını sanıyorum.

Sub Ozet_Tablo()
    
Dim i       As Long, _
    j       As Long, _
    Adet    As Integer, _
    Syf1    As Worksheet, _
    Syf2    As Worksheet, _
    d, _
    s, _
    a1, _
    Lst()
    
    Set Syf1 = Sheets("Sayfa1")
    Set Syf2 = Sheets("Sayfa2")
    Syf1.Select
    
    Application.ScreenUpdating = False
    i = Cells(Rows.Count, "A").End(3).Row
    Lst = Range("A2:D" & i)
    
    Set d = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(Lst)
        If Not d.exists(Lst(i, 1)) Then
            s = Array(Lst(i, 1), Lst(i, 1), Lst(i, 2), Lst(i, 3), Lst(i, 4))
            d.Add Lst(i, 1), s
            Adet = Adet + 1
        Else
            s = d.Item(Lst(i, 1))
            s(4) = s(4) + Lst(i, 4)
            d.Item(Lst(i, 1)) = s
        End If
    Next i
    
    a1 = d.items
    
    Syf2.Select
    j = Cells(Rows.Count, "A").End(3).Row
    If j < 2 Then j = 2
    Range("A2:D" & j).ClearContents
    
    For i = 0 To d.Count - 1
        s = a1(i)
        Cells(i + 2, "A") = s(1)
        Cells(i + 2, "B") = s(2)
        Cells(i + 2, "C") = s(3)
        Cells(i + 2, "D") = s(4)
    Next i
    Application.ScreenUpdating = True
    
    MsgBox Adet & " Adet Değişik Kayıt Var...", vbInformation, "N.YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[sarman61]

Teşekkürler tüm yardımlar için.Sorunum çözülmüş oldu...

 

[İhsan Tank]

Teşekkürler tüm yardımlar için.Sorunum çözülmüş oldu...

rica ederim
:yazici:

 

[pespembe123]

Merhaba
Yazdığınız formülleri inceledim ama maalesef elimdeki excel verileriyle başa çıkamadım.
Ekli dosyada farklı satırlarda aynı kondlu veriler var. Ben aynı kod numarası olan ve beş sütünlu bu değerlerin toplanarak tek bir satır olmasını istiyorum.
Umarım yardımcı olusunuz
Çok teşekkürler

 

[İhsan Tank]

Merhaba
Yazdığınız formülleri inceledim ama maalesef elimdeki excel verileriyle başa çıkamadım.
Ekli dosyada farklı satırlarda aynı kondlu veriler var. Ben aynı kod numarası olan ve beş sütünlu bu değerlerin toplanarak tek bir satır olmasını istiyorum.
Umarım yardımcı olusunuz
Çok teşekkürler

Dosya yok mu_?