Filtreleme ve makro

[nevista]

ekli dosyadaki sayfa 2 de veriler bulunmaktadır.
ben öncelikle bunları alıcılara göre filitreleyip toplamlarını başka bir sayfada görebileceğim bir makro çalışması yapmak istiyorum ama diğer alıcıyı filitrelediğmde önceki değer bozuluyor.

yani 2 tane alıcınında toplam alımlarını aynı anda göremiyorum.

yani Aliye ait alımların 1. sayfada yaptığım butona basınca filitrelenip toplamını almak istiyorum. bunu yaparkende velinin değerininde doğru sonuç vermesi gerekiyor.

benim yaptığımda biri doğru diğeri yanlış oluyor. yardımlarınız için şimdi den teşekkürler.

 

[İhsan Tank]

ikisi aynı anda mı toplanacak butona tıkladığınızda
ben bunu anladım umarım doğru anlamışımdır.

 

[nevista]

evet öylede olabilir farketmez yani sadece tıkladıklarımızı toplasada olur sorun dikkat etiyseniz. birine tıklayınca diğerindeki değerde değişiyor ve doğru olmuyor sonuç

 

[İhsan Tank]

evet öylede olabilir farketmez yani sadece tıkladıklarımızı toplasada olur sorun dikkat etiyseniz. birine tıklayınca diğerindeki değerde değişiyor ve doğru olmuyor sonuç

boş bir module kopyalarak dener misiniz

Option Explicit
Sub topla()
Dim ts, kaplan, ali, veli
kaplan = MsgBox("Toplam Alıyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
ali = 2: veli = 2
Sheets("Sayfa1").Range("H1") = "ali"
Sheets("Sayfa1").Range("I1") = "veli"
For ts = 3 To Sheets("Sayfa2").Cells(65536, "W").End(xlUp).Row
If Sheets("Sayfa2").Cells(ts, "W") = Sheets("Sayfa1").Range("H1") Then
Sheets("Sayfa1").Cells(ali, "H") = Sheets("Sayfa2").Cells(ts, "V")
ali = ali + 1
Sheets("Sayfa1").Range("C7") = WorksheetFunction.Sum( _
Sheets("Sayfa1").Range("H2:H65536"))
ElseIf Sheets("Sayfa2").Cells(ts, "W") = Sheets("Sayfa1").Range("I1") Then
Sheets("Sayfa1").Cells(veli, "I") = Sheets("Sayfa2").Cells(ts, "V")
veli = veli + 1
Sheets("Sayfa1").Range("C8") = WorksheetFunction.Sum( _
Sheets("Sayfa1").Range("I2:I65536"))
End If
Next
Sheets("Sayfa1").Range("H:I").ClearContents
MsgBox "Toplamları Aldım", vbInformation, "Bitiş"
End Sub

 

[İhsan Tank]

herkes diyorki hep makro veriyorsun formülü yok mu_?
C7 hücresine

=ETOPLA(Sayfa2!$W$3:$W$65536;"ali";Sayfa2!$V$3:$V$65536)

C8 hücresine

=ETOPLA(Sayfa2!$W$3:$W$65536;"veli";Sayfa2!$V$3:$V$65536)

kopyalarak deneyiniz.
65536 satır baz alınmıştır.

 

[nevista]

evet oldu ikiside tam isteğim gibi emeğine sağlık Allah razı olsun...

 

[İhsan Tank]

evet oldu ikiside tam isteğim gibi emeğine sağlık Allah razı olsun...

Allah Hepimizden Razı Olsun
kolay gelsin
:yazici:

 

[nevista]

boş bir module kopyalarak dener misiniz

Option Explicit
Sub topla()
Dim ts, kaplan, ali, veli
kaplan = MsgBox("Toplam Alıyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
ali = 2: veli = 2
Sheets("Sayfa1").Range("H1") = "ali"
Sheets("Sayfa1").Range("I1") = "veli"
For ts = 3 To Sheets("Sayfa2").Cells(65536, "W").End(xlUp).Row
If Sheets("Sayfa2").Cells(ts, "W") = Sheets("Sayfa1").Range("H1") Then
Sheets("Sayfa1").Cells(ali, "H") = Sheets("Sayfa2").Cells(ts, "V")
ali = ali + 1
Sheets("Sayfa1").Range("C7") = WorksheetFunction.Sum( _
Sheets("Sayfa1").Range("H2:H65536"))
ElseIf Sheets("Sayfa2").Cells(ts, "W") = Sheets("Sayfa1").Range("I1") Then
Sheets("Sayfa1").Cells(veli, "I") = Sheets("Sayfa2").Cells(ts, "V")
veli = veli + 1
Sheets("Sayfa1").Range("C8") = WorksheetFunction.Sum( _
Sheets("Sayfa1").Range("I2:I65536"))
End If
Next
Sheets("Sayfa1").Range("H:I").ClearContents
MsgBox "Toplamları Aldım", vbInformation, "Bitiş"
End Sub

Eğer alıcılarda değişiklik olursa ozaman nasıl yapacağız yani başka alıcılarda girerse listeye

 

[İhsan Tank]

Eğer alıcılarda değişiklik olursa ozaman nasıl yapacağız yani başka alıcılarda girerse listeye

merhaba
o kod biraz uzun kaçtı

Option Explicit
Sub topla()
Dim ts
ts = MsgBox("Topluyorum", vbYesNo, "Onay")
If ts = vbNo Then Exit Sub
[COLOR="Red"]Sheets("Sayfa1").Range("C7") = WorksheetFunction.SumIf(Sheets("Sayfa2").Range("W:W"), _
"[COLOR="Blue"]ali[/COLOR]", Sheets("Sayfa2").Range("V:V"))[/COLOR]
Sheets("Sayfa1").Range("C8") = WorksheetFunction.SumIf(Sheets("Sayfa2").Range("W:W"), _
"veli", Sheets("Sayfa2").Range("V:V"))
MsgBox "Topladım", vbInformation, "Bitiş"
End Sub

kırmızı boyadığım yeri çoğaltırsınız. Kriter olarakta mavi boyadığım yeri değiştirirsiniz yeni eklediğinizde