• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

süz,topla ve yaz

I

isteobenim

Katılım
11 Temmuz 2009
Mesajlar
225
Excel Vers. ve Dili
Excel 2013 Türkçe (64 Bit)
Selamlar,

Konuyla ilgili örnek çalışmaları inceledim ama tam olarak içinden çıkamadım işin,
sorum ek dosya içerisindedir.Makro ile nasıl yapabileceğim konusunda,
Yardımlarınızı rica ederim.

Saygılar.
 

Ekli dosyalar

Son düzenleme:
Arkadaşlar,

Bu soruya cevap verebilecek yok mu acaba..
 
arkadaşım yemin ederim 3 defa okudum sorunu ama tam olarak bişey anlayamadım.. daha basit bir örnekle anlatırmısın şunu, anlarsak daha verilmli olabiliriz..
 
Merhaba,

Sorumu ilk mesajımda revize ettim.
 
Merhaba,

Üstadlar ÇOKETOPLA fonksiyonu ile aldığım sonuçları makro ile almak istiyorum.Uygulamada veri ve kriterler çok fazla olacağı için çok sıkıntı oluyor.
Örnek dosya ilk mesajımda mevcuttur.
Üstadlardan yardım bekliyorum.Lütfen ilgilenebilirmisiniz.
İyi Çalışmalar,
 
Son düzenleme:
Merhaba,

Üstadlar ÇOKETOPLA fonksiyonu ile aldığım sonuçları makro ile almak istiyorum.Uygulamada veri ve kriterler çok fazla olacağı için çok sıkıntı oluyor.
Örnek dosya ilk mesajımda mevcuttur.
Üstadlardan yardım bekliyorum.Lütfen ilgilenebilirmisiniz.
İyi Çalışmalar,
 
Merhaba,

Üstadlar ÇOKETOPLA fonksiyonu ile aldığım sonuçları makro ile almak istiyorum.Uygulamada veri ve kriterler çok fazla olacağı için çok sıkıntı oluyor.
Örnek dosya ilk mesajımda mevcuttur.
Üstadlardan yardım bekliyorum.Lütfen ilgilenebilirmisiniz.
İyi Çalışmalar,
 
Merhaba,

Üstadlar ÇOKETOPLA fonksiyonu ile aldığım sonuçları makro ile almak istiyorum.Uygulamada veri ve kriterler çok fazla olacağı için çok sıkıntı oluyor.
Örnek dosya ilk mesajımda mevcuttur.
Üstadlardan yardım bekliyorum.Lütfen ilgilenebilirmisiniz.
İyi Çalışmalar,
 
Selamlar,

Aşağıdaki kod ile bu işlemi yapabilirsiniz. Fakat bahsettiğiniz gibi 650.000 satır ve yukarısı için kodun sonuç vermesi çok zaman alacaktır. Bu yönteme alternatif olarak hız açısından ADO ile çözüm üretilebilir ya da Scripting.Dictonary ile çözüm üretilebilir.

Kod: 
Option Explicit
 
Sub SÜZ_TOPLA()
    Dim X As Byte, Y As Byte
    
    Application.Calculation = xlCalculationManual
    
    For X = 5 To 19
        For Y = 7 To 13
            ActiveSheet.Range("$A$3:$D$1048576").AutoFilter Field:=1, Criteria1:=Cells(4, Y)
            ActiveSheet.Range("$A$3:$D$1048576").AutoFilter Field:=2, Criteria1:=Cells(X, "F")
            ActiveSheet.Range("$A$3:$D$1048576").AutoFilter Field:=4, Criteria1:="G"
            Cells(X, Y) = WorksheetFunction.Subtotal(9, Range("C:C"))
        Next
    Next
    For X = 22 To 36
        For Y = 7 To 13
            ActiveSheet.Range("$A$3:$D$1048576").AutoFilter Field:=1, Criteria1:=Cells(21, Y)
            ActiveSheet.Range("$A$3:$D$1048576").AutoFilter Field:=2, Criteria1:=Cells(X, "F")
            ActiveSheet.Range("$A$3:$D$1048576").AutoFilter Field:=4, Criteria1:="C"
            Cells(X, Y) = WorksheetFunction.Subtotal(9, Range("C:C"))
        Next
    Next
    
    ActiveSheet.Range("$A$3:$D$1048576").AutoFilter
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Merhaba,

Korhan Bey,

Yardımınız için teşekkür ederim.

Döngüler hücrelere tam oturmuyordu bu nedenle kodlarda birkaç değişiklik yapmak ve bir döngü daha eklemek zorunda kaldım.Eksi değerleri artı olarak göstermek içinde küçük bir eklenti yaptım.Ancak bu değişikleri yapmadan dahi ekte de görüleceği gibi boş (0) olması gereken hücrelerde "802" değeri çıkmaktadır.Sabahtan beri uğraşıyorum ama çözemedim.Aslında şuan ki kodlar ile bir defa doğru sonuç alabildim ama bir defa oldu.Kodlar haricinde başka bir problem var gibi ama çözemedim.xlsm.olarak kaydedip çalıştırınca da değişmiyor.Rica etsem kontrol edebilirmisiniz.
 

Ekli dosyalar

Selamlar,

Aşağıdaki kodda hatalı bölümleri düzelterek kırmızı renkle belirttim.

Kod: 
Option Explicit
 
Sub SÜZ_TOPLA()
    Dim X As Byte, Y As Byte, Z As Byte
    Dim basla As Date, bitis As Date
      
    Application.ScreenUpdating = False
    
    basla = Time
    
    For X = 3 To 17
        For Y = 7 To 13
            
            ActiveSheet.Range("$A$[B][COLOR=red]1[/COLOR][/B]:$D$15000").AutoFilter Field:=1, Criteria1:=Cells(2, Y)
            ActiveSheet.Range("$A$[COLOR=red][B]1[/B][/COLOR]:$D$15000").AutoFilter Field:=2, Criteria1:=Cells(X, "F")
            ActiveSheet.Range("$A$[COLOR=red][B]1[/B][/COLOR]:$D$15000").AutoFilter Field:=4, Criteria1:="G"
            Cells(X, Y) = WorksheetFunction.Subtotal(109, ActiveSheet.Range("C:C")) * -1
        
        Next
    Next
    
    For Z = 20 To 34
        
        For Y = 7 To 13
            ActiveSheet.Range("$A$[COLOR=red][B]1[/B][/COLOR]:$D$15000").AutoFilter Field:=1, Criteria1:=Cells(19, Y)
            ActiveSheet.Range("$A$[COLOR=red][B]1[/B][/COLOR]:$D$15000").AutoFilter Field:=2, Criteria1:=Cells(Z, "F")
            ActiveSheet.Range("$A$[COLOR=red][B]1[/B][/COLOR]:$D$15000").AutoFilter Field:=4, Criteria1:="C"
            Cells(Z, Y) = WorksheetFunction.Subtotal(109, ActiveSheet.Range("C:C"))
        
        Next
    
    Next
    
    ActiveSheet.Range("$A$[COLOR=red][B]1[/B][/COLOR]:$D$15000").AutoFilter
    
    Application.ScreenUpdating = True
    
    bitis = Time
    
    MsgBox "İşlem tamamlanmıştır." & vbCrLf & Format((basla - bitis), "hh:mm:ss"), vbInformation, "İşlem Kontrolü"
End Sub
 
Günaydın,

Teşekkür ederim üstadım.
Küçük bir ayrıntı ama beni bir gün uğraştırdı:)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst