Mükerrer gruplara ait adet ve sürelerin toplamı

[xlsx]

Arkadaşlar Slm
Mükerrer verilerden oluşan bir dosyada belirli kriterdeki mükerrerleri teke düşürme işlemi için gerekli kodlarım hazır, ancak aşağıdaki konuyu da eklemek istedim.Pivot ve formüller yapabiliyorum ancak veri çok olduğunda bazı sorunlar çıkartmakta.
Dosyada yeralan bilgi için yardımınızı rica ederim.
BBB sütunundaki veriler AAA'daki malzeme isimleriyle birlikte gruplayıp toplam süreyi almak istiyorum.Gruplama sonunda dosyada solda yeralan şekle gelmeli.
Örnek SİLGİ 2 adet farklı sicil numarasına sahip olduğu için adet olarak 2 çıkmalı ama sürelerin toplamını bu 2 adetin karşısına yazmalı.

 

[fedeal]

Merhaba, döngü kullanarak bir çözüm buldum. Veri çok olduğunda hesaplama süresi problem olmazsa iş görebilir. iyi çalışmalar.

Sub n()
Dim satır, i As Long
Dim bul As Range
Range("F2:I65000").ClearContents
satır = 1
For i = 2 To 10
Set bul = Range("f2:f65000").Find(Cells(i, 1).Value, , xlValues, xlWhole)
If Not bul Is Nothing Then
If Cells(bul.Row, 9).Value = Cells(i, 2).Value Then
Else
Cells(bul.Row, 9).Value = Cells(i, 2).Value
Cells(bul.Row, 7).Value = CDbl(Cells(bul.Row, 7).Value) + 1
End If
Else
satır = satır + 1
Cells(satır, 6).Value = Cells(i, 1).Value
Cells(satır, 9).Value = Cells(i, 2).Value
Cells(satır, 7).Value = 1
Cells(satır, 8).Value = WorksheetFunction.SumIf(Range("a:a"), Cells(i, 1).Value, Range("c:c"))
End If
Next
Range("I2:I65000").ClearContents
End Sub

 

[xlsx]

Selam
Defter Kalem gibi yeni malzeme adı eklendiğinde aynı seri numarasına sahip malzemeler için seri numaraları 1er 1er saymamakta.Örnekteki gibi aynı seri numarasına sahipse bunu 1 kabul edip toplamalı.

 

[fedeal]

İstediğiniz gibi yapıyor ancak döngü sayısını düzelttim sorun buydu zannedersem.

Sub n()
Dim satır, i As Long
Dim bul As Range
Range("F2:I65000").ClearContents
satır = 1
For i = 2 To [COLOR="Red"]Range("A65536").End(xlUp).Row[/COLOR]
Set bul = Range("f2:f65000").Find(Cells(i, 1).Value, , xlValues, xlWhole)
If Not bul Is Nothing Then
If Cells(bul.Row, 9).Value = Cells(i, 2).Value Then
Else
Cells(bul.Row, 9).Value = Cells(i, 2).Value
Cells(bul.Row, 7).Value = CDbl(Cells(bul.Row, 7).Value) + 1
End If
Else
satır = satır + 1
Cells(satır, 6).Value = Cells(i, 1).Value
Cells(satır, 9).Value = Cells(i, 2).Value
Cells(satır, 7).Value = 1
Cells(satır, 8).Value = WorksheetFunction.SumIf(Range("a:a"), Cells(i, 1).Value, Range("c:c"))
End If
Next
Range("I2:I65000").ClearContents
End Sub

 

[Ali]

G2 hücresine

=TOPLA(EĞER(SIKLIK(EĞER($A$2:$A$100=$F2;KAÇINCI("~"&B$2:B$100;B$2:B$100&"";0));SATIR(B$2:B$100)-SATIR($B$2)+1);1))

yazıp CTRL+SHIFT+ENTER tuşuna basıp aşağı doğru çekiniz.

H2 hücresine

=ETOPLA($A$2:$A$100;F2;$C$2:$C$100)

yazıp aşağı doğru çekiniz.

.

 

[xlsx]

Hem kod hem de fonksiyonlu çözüm için Fedeal ve Ali Hocama teşekkürler.Ellerinize sağlık.

 

[xlsx]

Sorunu B kolonu sıralatarak çözüm ancak yukardaki kodlar çalıştırıldığında eğer B sütunu sıralı değil ve benzer rakamlar aralıklı olarak varsa bu durumda her birini tek saymak yerine sanki yeni bir rakammış gibi adetini alıyor.Sıralama yaparak benzer rakamlar altalta geldiğinde böyle bi sorun olmamakta.Bu kodda nasıl bir değişiklik yapmam gerekecek yardımınızı rica ederim
Cells(bul.Row, 7).Value = CDbl(Cells(bul.Row, 7).Value) + 1

 

[Orion1]

Sorunu B kolonu sıralatarak çözüm ancak yukardaki kodlar çalıştırıldığında eğer B sütunu sıralı değil ve benzer rakamlar aralıklı olarak varsa bu durumda her birini tek saymak yerine sanki yeni bir rakammış gibi adetini alıyor.Sıralama yaparak benzer rakamlar altalta geldiğinde böyle bi sorun olmamakta.Bu kodda nasıl bir değişiklik yapmam gerekecek yardımınızı rica ederim
Cells(bul.Row, 7).Value = CDbl(Cells(bul.Row, 7).Value) + 1

Dosyanız ektedir.

Sub mukerrer()
Dim z As Object, vkey, i As Long, a(), n, j, myarr(), t As Object
Set z = CreateObject("Scripting.Dictionary")
Set t = CreateObject("Scripting.Dictionary")
a = Range("A2:C" & Cells(65536, "A").End(xlUp).Row).Value
Range("F2:H65536").ClearContents
For i = LBound(a, 1) To UBound(a, 1)
    If Not z.exists(a(i, 1) & "-" & a(i, 2)) Then
        z.Add a(i, 1) & "-" & a(i, 2), a(i, 3)
        Else
        z.Item(a(i, 1) & "-" & a(i, 2)) = z.Item(a(i, 1) & "-" & a(i, 2)) + a(i, 3)
    End If
Next
ReDim myarr(1 To z.Count, 1 To 3)
For Each vkey In z.keys
    j = Split(vkey, "-")
    If Not t.exists(j(0)) Then
        n = n + 1
        t.Add j(0), n
        myarr(n, 1) = j(0)
    End If
        myarr(t.Item(j(0)), 2) = myarr(t.Item(j(0)), 2) + 1
        myarr(t.Item(j(0)), 3) = myarr(t.Item(j(0)), 3) + z.Item(vkey)
Next
Range("F2").Resize(n, 3).Value = myarr
Set z = Nothing
Set t = Nothing
MsgBox "İşlem tamamdır.", vbOKOnly + vbInformation, "EVREN"

End Sub

 

[peleryn]

Yanlış yere mesaj yazdım silmeye çalıştım beceremedim.Yok yere konuyu benim hatam yüzümden açıp vakit kaybeden herkesten özür dilerim

 

[Orion1]

Lütfen sorunuz yeni bir başlık altında açıp sorunuz.Bu seferlik yanıtladım.Bir daha yanıtlamam.Böyle esas konu dağılıyor.Konuya virüs girmiş gibi oluyor.

Private Sub UserForm_Activate()
TextBox1.Text = WorksheetFunction.CountIf(Range("AH2:AH65536"), "FİZİKSEL")
End Sub

 

[xlsx]

Sn Evren Hocam, ilk defa bu kadar karışık bir kod görüyorum, anlamaya çalışsam da şuana kadar öğrendiğim bilgilerden tamamen yabancı gibi gözüktü gözüme.2 yıldır VBA kullanıyor olmama rağmen daha önce görmedim kodlamalarla karşılaştım
Kod sorunsuz çalıştı, B sütununda sıralama yapmama gerek kalmadan doğru sayım yapıyor.Koddaki bilgileri açıklar mısınız öğrenmek istiyorum desem sanırım sizi yormuş olurum
Örneğin bunu ilk kez gördüm ve neden böyle bi set değeri verdiğimizi anlayamadım:

Set z = CreateObject("Scripting.Dictionary")

 

[Orion1]

CreateObject konusunda fazla geniş bilgiye sahip değilim.
Bu konuyu google arayabilirsiniz.