Filtrelenen Ürünlerin Benzersiz Toplamlarını Alma

[y.selim]

Merhabalar

Herhangi bir siparişi süzdüğümüzde hangi üründen kaç adet olduğunu nasıl bulabiliriz?

Örnek dosyada detaylı anlatmaya çalıştım.

Formül yada makro fark etmez.

Soru ile ilgili vakit ayıran herkese teşekkürlerimi sunarım.

 

[Orion1]

Dosyanız ektedir.

Sub benzersiz59()
Dim hcr As Range, sonsat As Long
Dim z As Object
Range("E:F").ClearContents
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
sat = 2
Set z = CreateObject("Scripting.dictionary")
For Each hcr In Range("B2:B" & sonsat).SpecialCells(xlCellTypeVisible)
    If Not z.exists(hcr.Value) Then
        z.Add hcr.Value, 1
        Else
        z.Item(hcr.Value) = z.Item(hcr.Value) + 1
    End If
Next
Range("E27").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
Set z = Nothing
MsgBox "İşlem tamamlamlandı." & vbLf & "evrengizlen@hotmail.com"

End Sub

 

[halit3]

Alternatif kod

Filitreme işlemini iptal edin aranan değeri D1 hücresine yazın ve kodu çalıştırın

kod:

Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer


Range("e1:f" & Rows.Count).Clear
son1 = Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1)

For j = 2 To son1
If WorksheetFunction.Trim(Cells(j, "a")) = WorksheetFunction.Trim(Cells(1, "d")) Then
ara1(j) = WorksheetFunction.Trim(Cells(j, "a")) & WorksheetFunction.Trim(Cells(j, "b"))
ara2(j) = 1
Else
ara1(j) = ""
End If

Next j

sat1 = 1

For r = 2 To son1
aranan1 = ara1(r)

sut2 = 0
If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sut2 = sut2 + 1
ara2(i) = 0
End If
Next i

Cells(sat1, "e").Value = Cells(r, 2).Value
Cells(sat1, "f").Value = sut2

sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

 

[y.selim]

İki tane harika çözüm. Çok teşekkürler Evren Hocam ve Halit Hocam ellerinize sağlık.

 

[y.selim]

Arkadaşlar affınıza sığınarak bir ilave yaptırmam mümkün mü? Bir yeri atlamışım.

Toplamların ürünlerin kendilerini sayarak değil de, eklediğim C sütunundaki adetlerden elde

edilmesi lazım.Örnek dosyayı bu şekilde güncelledim.Yardımcı olabilirseniz sevinirim.İyi

çalışmalar.

 

[Korhan Ayhan]

Evren beyin kodunu aşağıdaki gibi değiştirip deneyiniz.

Sub benzersiz59()
Dim hcr As Range, sonsat As Long
Dim z As Object
Range("E:F").ClearContents
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
sat = 2
Set z = CreateObject("Scripting.dictionary")
For Each hcr In Range("B2:B" & sonsat).SpecialCells(xlCellTypeVisible)
    If Not z.exists(hcr.Value) Then
        z.Add hcr.Value, 1
        Else
        z.Item(hcr.Value) = z.Item(hcr.Value) + hcr.Offset(0, 1).Value
    End If
Next
Range("E27").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
Set z = Nothing
MsgBox "İşlem tamamlamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[halit3]

Arkadaşlar affınıza sığınarak bir ilave yaptırmam mümkün mü? Bir yeri atlamışım.

Toplamların ürünlerin kendilerini sayarak değil de, eklediğim C sütunundaki adetlerden elde

edilmesi lazım.Örnek dosyayı bu şekilde güncelledim.Yardımcı olabilirseniz sevinirim.İyi

çalışmalar.

Kod:

Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer


Range("e1:f" & Rows.Count).Clear
son1 = Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1)

For j = 2 To son1
If WorksheetFunction.Trim(Cells(j, "a")) = WorksheetFunction.Trim(Cells(1, "d")) Then
ara1(j) = WorksheetFunction.Trim(Cells(j, "a")) & WorksheetFunction.Trim(Cells(j, "b"))
ara2(j) = 1
Else
ara1(j) = ""
End If

Next j

sat1 = 1

For r = 2 To son1
aranan1 = ara1(r)

sut2 = 0
If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sut2 = sut2 + [COLOR="Red"]Cells(i, "c")[/COLOR]
ara2(i) = 0
End If
Next i

Cells(sat1, "e").Value = Cells(r, 2).Value
Cells(sat1, "f").Value = sut2

sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

 

[y.selim]

Halit Bey çok teşekkür ederim kodlar gayet güzel iş görüyor.Emeğinize sağlık.

Selametle kalın.

 

[halit3]

Halit Bey çok teşekkür ederim kodlar gayet güzel iş görüyor.Emeğinize sağlık.

Selametle kalın.

Teşekkürler iyi çalışmalar