makro ile birden fazla koşula göre topla ve sabite aktar

isteobenim · 16 Mart 2010

Selam arkadaşlar,

Sorum ekli örnek dosya içerisindedir.

Yardımlrınız için şimdiden teşekkürler,

Korhan Ayhan · 17 Mart 2010

Selamlar,

Tabloda A verisi için formül içindeki 4. sorguda kriter "NA" iken ikinci kısımda "NB" diğer harfler içinde bu şekildemi olacak?

isteobenim · 17 Mart 2010

Selam Korhan Bey,

Evet biraz karışık olacak ama malesef bu şekilde

isteobenim · 18 Mart 2010

Üstadlar,

Yardımcı olabilecek yokmu acaba?

Korhan Ayhan · 18 Mart 2010

Selamlar,

Döngü ile hazırladığım örnek dosyayı incelermisiniz. Yalnız döngü olduğu için işlem süresi yaklaşık 6 dk sürüyor. Filtre ve alttoplam ile bir örnek daha hazırlayacağım. Daha hızlı sonuç elde edebilirsem tamamlanınca onuda eklerim.

Kullanılan kod; (Boş bir modüle uygulayın)

Kod:

Option Explicit
 
Sub KOŞULLU_TOPLAM()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Satır As Long, Sütun As Byte
    Dim Kriter As Integer, Ölçüt As String
    Dim BUL As Range, ADRES As String
    Dim İLK As Date, SON As Date
 
    İLK = Time
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Kriter = 2
 
    For X = 3 To S2.Range("B65536").End(3).Row Step 24
    Ölçüt = "NA"
        For Satır = X To X + 21
            For Sütun = 3 To 16
            S2.Cells(Satır, Sütun) = Empty
 
            If S2.Cells(Kriter, Sütun) = "Gİ" Or S2.Cells(Kriter, Sütun) = "İA" Or _
            S2.Cells(Kriter, Sütun) = "SE" Or S2.Cells(Kriter, Sütun) = "FA" Then
 
            Set BUL = S1.Range("A:A").Find(S2.Cells(X, 1), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
            If S1.Cells(BUL.Row, "C") = S2.Cells(Satır, "B") Then
            If S1.Cells(BUL.Row, "D") = S2.Cells(Kriter, Sütun) Then
            S2.Cells(Satır, Sütun) = S2.Cells(Satır, Sütun) + S1.Cells(BUL.Row, "E")
            End If
            End If
            Set BUL = S1.Range("A:A").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
 
            Else
 
            Set BUL = S1.Range("A:A").Find(S2.Cells(X, 1), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
            If S1.Cells(BUL.Row, "B") = S2.Cells(Kriter, Sütun) Then
            If S1.Cells(BUL.Row, "C") = S2.Cells(Satır, "B") Then
            If S1.Cells(BUL.Row, "D") = Ölçüt Then
            S2.Cells(Satır, Sütun) = S2.Cells(Satır, Sütun) + S1.Cells(BUL.Row, "E")
            End If
            End If
            End If
            Set BUL = S1.Range("A:A").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
 
            End If
            Next
            If Satır - X = 9 Then
            Satır = Satır + 2
            Kriter = Kriter + 12
            Ölçüt = "NB"
            End If
        Next
        Kriter = Kriter + 12
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    SON = Time
 
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & Format((SON - İLK), "hh:mm:ss"), vbInformation
End Sub

Korhan Ayhan · 19 Mart 2010

Selamlar,

Bu örnek dosyada filtreleme ve alttoplam işlemi kullanılmıştır. İşlem süresi yaklaşık 10 Sn sürmektedir.

Kullanılan kod; (Boş bir modüle uygulayın)

Kod:

Option Explicit
 
Sub KOŞULLU_TOPLAM()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Satır As Long, Sütun As Byte
    Dim Kriter As Integer, Ölçüt As String
    Dim İLK As Date, SON As Date
    
    Application.ScreenUpdating = False
    
    İLK = Time
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Kriter = 2
    
    For X = 3 To S2.Range("B65536").End(3).Row Step 24
    Ölçüt = "NA"
        For Satır = X To X + 21
            For Sütun = 3 To 16
            S2.Cells(Satır, Sütun) = Empty
            
            If S2.Cells(Kriter, Sütun) = "Gİ" Or S2.Cells(Kriter, Sütun) = "İA" Or _
            S2.Cells(Kriter, Sütun) = "SE" Or S2.Cells(Kriter, Sütun) = "FA" Then
            
            S1.Range("A1").AutoFilter
            S1.Range("A1").AutoFilter Field:=1, Criteria1:=S2.Cells(X, "A")
            S1.Range("A1").AutoFilter Field:=3, Criteria1:=S2.Cells(Satır, "B")
            S1.Range("A1").AutoFilter Field:=4, Criteria1:=S2.Cells(Kriter, Sütun)
            S2.Cells(Satır, Sütun) = WorksheetFunction.Subtotal(109, S1.Range("E:E"))
            
            Else
            
            S1.Range("A1").AutoFilter
            S1.Range("A1").AutoFilter Field:=1, Criteria1:=S2.Cells(X, "A")
            S1.Range("A1").AutoFilter Field:=2, Criteria1:=S2.Cells(Kriter, Sütun)
            S1.Range("A1").AutoFilter Field:=3, Criteria1:=S2.Cells(Satır, "B")
            S1.Range("A1").AutoFilter Field:=4, Criteria1:=Ölçüt
            S2.Cells(Satır, Sütun) = WorksheetFunction.Subtotal(109, S1.Range("E:E"))
            
            End If
            Next
            If Satır - X = 9 Then
            Satır = Satır + 2
            Kriter = Kriter + 12
            Ölçüt = "NB"
            End If
        Next
        Kriter = Kriter + 12
    Next
    
    S1.Range("A1").AutoFilter
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    SON = Time
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & Format((SON - İLK), "hh:mm:ss"), vbInformation
End Sub

isteobenim · 19 Mart 2010

Korhan Bey,

Her iki cevabınız içinde çok teşekkür ederim.
Bu şekli ile dahi müthiş bir çalışma olmuş durumda,

Ancak sizden iki ricam daha olacak,

Mümkünse 2.örnekteki (süzerek yapılan işlem) kodları tabiri caiz ise satır satır açıklayabilir misiniz?

Çok işime yarayacak bir örnek olduğu için küçük düzenlemeler yaparak, benzer diğer çalışmalarımda kullanacağım.

Birde örnek tablolardaki sütun sabit değerleri yer değiştirdiğinde de doğru sonucu almak için kodlarda nasıl bir değişiklik yapılması gerekecek,

Ben yer değişikliği yaparak denedim, ilginç ama sadece B tablosunun SE kısmında doğru sonucu alabildim. Diğer taraflar karıştı.

Örneğin,

A tablosunda
Gİ Lokal1 , Lokal2………………………Lokal12
SE Lokal1 , Lokal2………………………Lokal12 sıralaması

B tablosunda
Gİ Lokal3 , Lokal4,………………………Lokal12 , Lokal1 , Lokal2
SE Lokal3 , Lokal4,………………………Lokal12 , Lokal1 , Lokal2 gibi

C tablosunda
Gİ Lokal12 , Lokal1,………………….…Lokal10 , Lokal11, Lokal1
SE Lokal12 , Lokal1,………………….…Lokal10 , Lokal11, Lokal1 gibi olursa yine sayfa1 den bu bu değerlere ait toplamları alıp yazacak,

Yani tablonun başlangıcındaki ilk (Gİ) satırındaki verileri kriter olarak kabul edeceğiz.(Satır adresleri her tablo için sabittir. Bunu da bilgi olarak belirteyim)

Korhan Ayhan · 19 Mart 2010

Selamlar,

Kriterlerinizin sabit olduğunu düşünerek kodu bu şekilde düzenlemiştim. Eğer son mesajınızdaki gibi karışık düzende olacaksa ekteki örnek dosyayı kullanabilirsiniz.

Koda ait açıklamaları satır aralarına ekledim. Umarım faydası olur.

Kod:

Option Explicit
 
Sub KOŞULLU_TOPLAM() [COLOR=red]'Makromuza isim veriyoruz.[/COLOR]
 
    [COLOR=red]'Makromuzda kullanacağımız değişkenleri tanımlıyoruz.[/COLOR]
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Satır As Long, Sütun As Byte
    Dim Kriter As Integer, Ölçüt As String
    Dim İLK As Date, SON As Date
 
    [COLOR=red]'Ekran hareketlerini pasif hale getiriyoruz.[/COLOR]
    Application.ScreenUpdating = False
 
   [COLOR=red]'Makromuzun işlemi yapma süresini bulmak için başlangıç zamanını tanımlıyoruz.[/COLOR]
    İLK = Time
 
    [COLOR=red]'Sayfa isimlerini kısaltarak tanımlıyoruz.[/COLOR]
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
 
   [COLOR=red]'Hesaplamada kullanılacak kriterlerin başlangıç satır nosunu tanımlıyoruz.[/COLOR]
    Kriter = 2
 
   [COLOR=red]'X isimli bir döngü tanımlıyoruz.[/COLOR]
    For X = 3 To S2.Range("B65536").End(3).Row Step 24
 
   [COLOR=red]'Ölçüt değerini tanımlıyoruz.[/COLOR]
    Ölçüt = "NA"
 
        [COLOR=red]'Satır isimli bir döngü tanımlıyoruz. Bu döngü B sütunundaki değişkenleri kontrol etmek için tanımlanmıştır.[/COLOR]
        For Satır = X To X + 21
 
            [COLOR=red]'Sütun isimli bir döngü tanımlıyoruz. C-P arasındaki sütunları temsil etmektedir.[/COLOR]
            For Sütun = 3 To 16
 
            [COLOR=red]'İlk olarak hesaplama sonucunun yazılacağı hücrenin içeriğini temizliyoruz.[/COLOR]
            S2.Cells(Satır, Sütun) = Empty
 
           [COLOR=red]'Kriter satırlarının (Sarı renkli satırlar) "Gİ" , "İA" , "SE" , "FA" değerlerine eşit olmasını sorguluyoruz.[/COLOR]
            If S2.Cells(Kriter, Sütun) = "Gİ" Or S2.Cells(Kriter, Sütun) = "İA" Or _
            S2.Cells(Kriter, Sütun) = "SE" Or S2.Cells(Kriter, Sütun) = "FA" Then
 
           [COLOR=red]'Eğer bir önceki sorgu sonucu olumlu ise aşağıdaki filtreleme işlemleri yapılmaktadır.[/COLOR]
            [COLOR=red]'İlk olarak Sayfa1 deki filtreyi pasif hale getiriyoruz.[/COLOR]
            S1.Range("A1").AutoFilter
 
            [COLOR=red]'Sayfa1 deki A sütununa filtre uyguluyoruz. Yani X döngüsünün ilk değeri olan "A" değerini filtreliyoruz.[/COLOR]
            S1.Range("A1").AutoFilter Field:=1, Criteria1:=S2.Cells(X, "A")
 
           [COLOR=red]'Sayfa1 deki C sütununa filtre uyguluyoruz. Yani Satır değişkeninin ilk değeri olan "H2" değerini filtreliyoruz.[/COLOR]
            S1.Range("A1").AutoFilter Field:=3, Criteria1:=S2.Cells(Satır, "B")
 
           [COLOR=red]'Sayfa1 deki D sütununa filtre uyguluyoruz. Yani Sütun döngüsünün ilk değeri olan "C2" hücresinin değerini filtreliyoruz.[/COLOR]
            S1.Range("A1").AutoFilter Field:=4, Criteria1:=S2.Cells(Kriter, Sütun)
 
            [COLOR=red]'Tüm filtreler uygulandıktan sonra görünen satırlar için alttoplam formülü ile sonucu hesaplayıp ilgili hücreye aktarıyoruz.[/COLOR]
            S2.Cells(Satır, Sütun) = WorksheetFunction.Subtotal(109, S1.Range("E:E"))
 
           [COLOR=red]'IF sorgumuzun sonucu olumsuz ise[/COLOR]
            Else
 
            [COLOR=red]'İlk olarak Sayfa1 deki filtreyi pasif hale getiriyoruz.[/COLOR]
            S1.Range("A1").AutoFilter
 
            [COLOR=red]'Sayfa1 deki A sütununa filtre uyguluyoruz. Yani X döngüsünün ilk değeri olan "A" değerini filtreliyoruz.[/COLOR]
            S1.Range("A1").AutoFilter Field:=1, Criteria1:=S2.Cells(X, "A")
 
           [COLOR=red]'Sayfa1 deki B sütununa filtre uyguluyoruz. Yani Sütun döngüsünün ilk değeri olan "C2" hücresinin değerini filtreliyoruz.[/COLOR]
            S1.Range("A1").AutoFilter Field:=2, Criteria1:=S2.Cells(Kriter, Sütun)
 
           [COLOR=red]'Sayfa1 deki C sütununa filtre uyguluyoruz. Yani Satır değişkeninin ilk değeri olan "H2" değerini filtreliyoruz.[/COLOR]
            S1.Range("A1").AutoFilter Field:=3, Criteria1:=S2.Cells(Satır, "B")
 
            [COLOR=red]'Sayfa1 deki D sütununa filtre uyguluyoruz. Yani Ölçüt değişkeninin ilk değeri olan "NA" değerini filtreliyoruz.[/COLOR]
            S1.Range("A1").AutoFilter Field:=4, Criteria1:=Ölçüt
 
            [COLOR=red]'Tüm filtreler uygulandıktan sonra görünen satırlar için alttoplam formülü ile sonucu hesaplayıp ilgili hücreye aktarıyoruz.[/COLOR]
            S2.Cells(Satır, Sütun) = WorksheetFunction.Subtotal(109, S1.Range("E:E"))
 
            [COLOR=red]'IF sorgumuzu sonlandırıyoruz.[/COLOR]
            End If
 
           [COLOR=red]'Sütun döngüsüne devam ediyoruz.[/COLOR]
            Next
 
            [COLOR=red]'Tablonuzda 12. satırdan sonra diğer tabloya geçerken sonraki iki satırın işleme alınmaması gerekiyor.[/COLOR]
           [COLOR=red]'Bunun için aşağıdaki IF sorgusunu kullanarak Satır,Kriter ve Ölçüt değişekenlerinin yeni değerlerini tanımlıyoruz.[/COLOR]
            If Satır - X = 9 Then
            Satır = Satır + 2
            Kriter = Kriter + 12
            Ölçüt = "NB"
            End If
 
       [COLOR=red]'Satır döngüsüne devam ediyoruz.[/COLOR]
        Next
 
        [COLOR=red]'Kriter değerinin üzerine 12 satır daha ekliyoruz.[/COLOR]
        Kriter = Kriter + 12
 
   [COLOR=red]'X döngüsüne devam ediyoruz.[/COLOR]
    Next
 
    [COLOR=red]'Hesaplama işlemleri tamamlandığı için Sayfa1 deki filtreleri pasif hale getiriyoruz.[/COLOR]
    S1.Range("A1").AutoFilter
 
   [COLOR=red]'Hafızaya aldığımız sayfa ismi kısaltmalarını hafızadan siliyoruz.[/COLOR]
    Set S1 = Nothing
    Set S2 = Nothing
 
    [COLOR=red]'Makromuzun işlemi yapma süresini bulmak için bitiş zamanını tanımlıyoruz.[/COLOR]
    SON = Time
 
    [COLOR=red]'Ekran hareketlerini tekrar aktif hale getiriyoruz.[/COLOR]
    Application.ScreenUpdating = True
 
    [COLOR=red]'İşlemin tamamlandığına dair kullanıcıya bilgilendirme mesajı veriyoruz.[/COLOR]
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & Format((SON - İLK), "hh:mm:ss"), vbInformation
[COLOR=red]'Makromuzu sonlandırıyoruz.[/COLOR]
End Sub

isteobenim · 19 Mart 2010

Selam Korhan Bey,

Cevap ve açıklamalarınız için teşekkür ederim.

Örnek dosyayı ilk kontrol ettiğimde B tablosunda H2, NA değeri 0 olmasına rağmen 29072,636 değeri yazılmış , bir yerde küçük bir atlama var gibi müsait olunca kontrol edebilirmisiniz.

Ayrıca değişkenlik tablo bazında (her iki sarı satırda bir) olacaktır.Daha doğrusu tam olarak şimdi ekledeğim örnek dosya gibi olacaktır.

Teşekkürler,

Korhan Ayhan · 19 Mart 2010

Selamlar,

Sanırım problemi buldum. Üstteki mesajımdaki kodu ve dosyayı güncelledim. İncelermisiniz.

isteobenim · 19 Mart 2010

Korhan Bey,

Sizi çok meşgul ediyorum ama,
B Lokal7 H2 NA değeri süz toplamı:1.873
raporu çalıştırınca Lokal8 de görünüyor,

Birde yine be sütunuda Gİ ile SE tam ters olarak sonuclanıyor.Yani Gİ değeri SE ye yazıyor,
SE değerini Gİ ye.

Korhan Ayhan · 19 Mart 2010

Selamlar,

Sn. kendirliii,

Son eklediğim dosyayı tekrar denedim. Fakat bende doğru sonuç verdi. 1873 değerini Lokal7 sütununa yazdı.

Ayrıca B-H2-Gİ kriterine göre Sayfa1 deki verileri süzdüğümde 19259,868 değerine ulaşıyorumki buda yine son eklediğim dosyada C27 hücresindeki değerle aynı.

Yanlış yorumladığım bölüm varsa lütfen açıklarmısınız?

isteobenim · 19 Mart 2010

Korhan Bey,

Yorumunuza göre sonuclar benim istediğim gibi, ve mutlaka da haklısınızdır ama biryerlerde başka bir problem var galiba, ben çalıştırdığım dosyayı tekrar ekledim.İncelyebilirmisiniz lütfen başka ne olabilir ki?(umarım beni sıkıntıya sokacak basit birşey değildir

Korhan Ayhan · 19 Mart 2010

Selamlar,

#8 nolu mesajımdaki dosyayı indirip tekrar deneyiniz. Kullandığınız kod daha önceki hatalı olan koddur.

isteobenim · 19 Mart 2010

Korhan Bey,

Emeğiniz için sonsuz teşekkürler,

İstediğim sonuca ulaştım.(ama önceki mesajımda belirttiğim gibi beni sıkıntıya sokan basit bir hata nedeniyle

sizi meşgul etmiş oldum kusura bakmayın

İyi Akşamlar,

makro ile birden fazla koşula göre topla ve sabite aktar

isteobenim

Ekli dosyalar

Korhan Ayhan

Administrator

isteobenim

isteobenim

Korhan Ayhan

Administrator

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

isteobenim

Korhan Ayhan

Administrator

Ekli dosyalar

isteobenim

Ekli dosyalar

Korhan Ayhan

Administrator

isteobenim

Korhan Ayhan

Administrator

isteobenim

Ekli dosyalar

Korhan Ayhan

Administrator

isteobenim