Çoklu sütunla gelişmiş filtre kullanımı

[mixser]

Merhaba arkadaşlar

Ekteki dosyamda çoklu stündan benzersiz tek liste çıkarmak istiyorum.Sorumun detayını dosya üzerinde anlatmaya çalıştım.
Herzaman olduğu gibi yardımlarınızı esirgemeyiniz lütfen.
Teşekkürler.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub listele()
Dim hucre As Range
Set s1 = Sheets("Flitre")
Set s2 = Sheets("Data")
s2.[a2:d65536].ClearContents
son = [a65536].End(3).Row
For Each hucre In s1.Range("a3:o" & son)
If WorksheetFunction.CountIf(s2.[a:a], hucre) = 0 And hucre <> "" Then
c = c + 1
s2.Cells(c + 1, "a") = hucre
s2.Cells(c + 1, "b") = WorksheetFunction.SumIf(s1.Range("a3:o" & son), hucre, s1.Range("q3:ae" & son))
s2.Cells(c + 1, "c") = WorksheetFunction.SumIf(s1.Range("a3:o" & son), hucre, s1.Range("ag3:au" & son))
s2.Cells(c + 1, "d") = Round(s2.Cells(c + 1, "c") / s2.Cells(c + 1, "b"), 2)
End If
Next
End Sub

 

[mixser]

Merhabalar sn. Leventm

Kod işe yarıyor lakin
ürün1, miktar1, tutar1 e yeni değerler girip kod çalıştırıldığında "Run-time'6' Overflow" hatası ile karşılaştım nedeni ne olabilir.
Saygılarımla

 

[mixser]

hata bu satır üzerinde oluşuyor
"s2.Cells(c + 1, "d") = Round(s2.Cells(c + 1, "c") / s2.Cells(c + 1, "b"), 2)"
anladığım kadarıyla boş olan hücreler hesaplanmaya çalışlıyor galiba çünkü data sayfasındaki listede
ürün kolonunun son satırı boşken karşısındaki kolonlarda "0" lar mevcut

 

[Levent Menteşoğlu]

Yukarıdaki kodu küçük bir ilave ile yeniledim tekrar deneyin.

 

[mixser]

evet çalıştı çok teşekkür ederim sn.Leventm
oldu olacak şunuda yapalım

kodu otomatik hale nasıl getirebiliriz yani listeye yeni veri girildiğinde makro her hangi bir butona basmadan otomatik olarak çalışmalı

 

[mixser]

Sn. Leventm

Vermiş olduğunuz kodu aşağıdaki şekliyle
Flitre sayfasının kod bölümüne yazdım ve istediğim oldu
çabalarınız için teşekkürlerimi sunar hayırlı ve uzun bir ömür yaşamanızı
dilerim.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim hucre As Range
On Error GoTo 10

Set s1 = Sheets("Flitre")
Set s2 = Sheets("Data")
s2.[a2:d65536].ClearContents
son = [a65536].End(3).Row
For Each hucre In s1.Range("a3" & son)
If WorksheetFunction.CountIf(s2.[a:a], hucre) = 0 And hucre <> "" Then

c = c + 1
s2.Cells(c + 1, "a") = hucre
s2.Cells(c + 1, "b") = WorksheetFunction.SumIf(s1.Range("a3" & son), hucre, s1.Range("q3:ae" & son))
s2.Cells(c + 1, "c") = WorksheetFunction.SumIf(s1.Range("a3" & son), hucre, s1.Range("ag3:au" & son))
s2.Cells(c + 1, "d") = Round(s2.Cells(c + 1, "c") / s2.Cells(c + 1, "b"), 2)

End If
10:
Next
End Sub