Altalta toplayarak ilerleme

ikikan · 5 Eylül 2016

Sub Ztopla()
Dim dizim(), veri, veri2
Dim i
satir = Sheets("DEPO").Cells(Rows.Count, 1).End(3).Row
Sheets("DEPO").Range("F5:G" & satir).Clear
veri = Sheets("DEPO").Range("A5:C" & satir).Value

ReDim dizim(1 To satir, 1 To 3)
For i = 1 To UBound(veri, 1)
say = say + 1
ReDim Preserve dizim(1 To satir, 1 To 3)
dizim(i, 1) = dizim(i, 1) + veri(i, 2) + veri(i, 3)
Next i
Sheets("DEPO").Range("F5").Resize(say, 1) = dizim

Sheets("DEPO").Range("G5:G" & i).Value = dizim
End Sub

Arkadaşlar bu makroyla Altalta toplayarak ilerlemek istiyorum fakat toplayarak ilerlemiyor ya toplam toplamı veriyor yada iki sütunu birleştiriyor altalta toplayarak ilerlemesi için ne yapmalıyım

Korhan Ayhan · 5 Eylül 2016

Toplama işlemini sayfa üzerinde örnekler misiniz?

ikikan · 5 Eylül 2016

Altalta Toplama Dizi

Sub Ztopla()
Dim dizim(), veri, veri2, dizim2()
Dim i
Dim top As Long
Dim s As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Application.Volatile

satir = Sheets("DEPO").Cells(Rows.Count, 1).End(3).Row
Sheets("DEPO").Range("F5:H" & satir).Clear
veri = Sheets("DEPO").Range("A5:C" & satir).Value
'say = 0
ReDim dizim(1 To satir, 1 To 3)
For i = 1 To UBound(veri, 1)
'say = say + 1
ReDim Preserve dizim(1 To satir, 1 To 3)
dizim(i, 1) = veri(i, 2) + veri(i, 3)
Next i
'Bu bölümüde dizi içine koymaya çalışıyorum işlem zamanı kısalması için
For s = 5 To satir
a = a + 1
top = top + dizim(a, 1)
Sheets("DEPO").Cells(s, 8) = top
Next s

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

'Kırmızı bölümüde dizi içine koymaya çalışıyorum işlem zamanı kısalması

Korhan Ayhan · 5 Eylül 2016

Deneyiniz.

Toplamları "E" sütununa alır. Değiştirmek isterseniz kırmızı alanlara müdahale ediniz.

Kod:

Sub Topla()
    Dim Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Range("[COLOR="Red"]E5:E[/COLOR]" & Son)
        .Formula = "=[COLOR="red"]E4[/COLOR]+B5+C5"
        .Value = .Value
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

ikikan · 7 Eylül 2016

Dizi içinde hesplama yaparak yazdırmak mükün değil anlaşılan

Korhan Ayhan · 7 Eylül 2016

Ben kolay yöntemi önerdim.

Dizi ile yapmak istiyorsanız aşağıdaki kodu deneyebilirsiniz.

Kod:

Option Explicit

Sub Topla()
    Dim S1 As Worksheet, Dizim(), Veri()
    Dim X As Long, Satir As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("DEPO")
    
    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row
    S1.Range("F5:H" & Satir).Clear
    Veri = S1.Range("A5:C" & Satir).Value
    
    ReDim Dizim(1 To UBound(Veri, 1), 1 To 3)
    
    For X = 1 To UBound(Veri, 1)
        ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 3)
        If X = 1 Then
            Dizim(X, 1) = Veri(X, 2) + Veri(X, 3)
        Else
            Dizim(X, 1) = Dizim(X - 1, 1) + Veri(X, 2) + Veri(X, 3)
        End If
    Next
    
    S1.Range("H5:H" & UBound(Dizim) + 4) = Dizim
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    Set S1 = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

ikikan · 7 Eylül 2016

Korhan Ayhan' Alıntı:

Deneyiniz.

Toplamları "E" sütununa alır. Değiştirmek isterseniz kırmızı alanlara müdahale ediniz.

Kod:

Sub Topla()
    Dim Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Range("[COLOR="Red"]E5:E[/COLOR]" & Son)
        .Formula = "=[COLOR="red"]E4[/COLOR]+B5+C5"
        .Value = .Value
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Kod:

Sub Ztopla()
Dim İlk As Date, Son As Date
Dim Zaman As Date
Dim Liste(), veri
Dim i
Dim SonSatır As Long
Dim Toplam As Double

  Zaman = Timer
  Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
            'Application.Volatile
            
                İlk = Time
                
SonSatır = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("DEPO").Range("H5:H" & SonSatır).Value = Clear

If Not Range("C1").Text = "" Then
    Liste = Range("A5:K" & SonSatır)
    
    ReDim veri(1 To SonSatır, 1 To 3)
        For i = 1 To UBound(Liste, 1)
            If Liste(i, 1) = Range("C1").Value Then
                    Say = Say + 1
                    ReDim Preserve veri(1 To SonSatır, 1 To 3)
                    veri(Say, 1) = Liste(i, 2) + Liste(i, 3)
         
         Toplam = Toplam + veri(Say, 1)
         Sheets("DEPO").Cells(i + 4, 8) = Toplam
         
           End If
        Next i
End If

Son = Time
    
              Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


Sheets("DEPO").Cells(1, 1) = Format((Son - İlk), "hh:mm:ss.00")
Sheets("DEPO").Cells(1, 2) = "İşlem süresi : " & Format(Timer - Zaman, "0.00000")
  
  'Değişkenleri Boşalt..............................................
SonSatır = Empty: i = Empty: Toplam = Empty
Erase Liste: Erase veri

  
End Sub

Aslında yapmak istediğim yukardaki koda olduğu gibi, koşula göre toplama yapması C1 hücresi de yazanı her değer için ayrı hesaplaması ve bu hesaplamayı 9 sn daha kısa yaptırmak örnek:1 sn içinde ne denediysem 9 sn altına indiremedim.

Sizin kod 0.3 sn yapıyor fakat onuda kendi makroma uyarlamaya kalkarsam çok uğraşmam gerekecek. lakin .Formula = Subtotal... ile birşey yapılabilirmi ?

Korhan Ayhan · 7 Eylül 2016

Sorunuzu sürekli değiştiriyorsunuz...

Tam olarak nasıl bir işlem yapmak istediğinizi örnek dosyanız üzerinde açıklarsanız tam sonuç üretecek kodu önerebilirim. Bu şekilde sürekli yeniden kod yazmak durumunda kalıyoruz.

ikikan · 7 Eylül 2016

Kod:

Sub Ztopla()
Dim İlk As Date, Son As Date
Dim Zaman As Date
Dim Liste(), veri
Dim i
Dim SonSatır As Long
Dim Toplam As Double

  Zaman = Timer
  Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        Application.EnableEvents = False
            'Application.Volatile
            
                İlk = Time
                
SonSatır = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("DEPO").Range("H5:H" & SonSatır).Value = Clear

If Not Range("C1").Text = "" Then
    Liste = Range("A5:K" & SonSatır)
    
    ReDim veri(1 To SonSatır, 1 To 3)
        For i = 1 To UBound(Liste, 1)
            If Liste(i, 1) = Range("C1").Value Then
                    Say = Say + 1
                    ReDim Preserve veri(1 To SonSatır, 1 To 3)
                    veri(Say, 1) = Liste(i, 2) + Liste(i, 3)
         
[COLOR="Red"]         Toplam = Toplam + veri(Say, 1)
         Sheets("DEPO").Cells(i + 4, 8) = Toplam[/COLOR]
         
           End If
        Next i
End If

Son = Time
    
              Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


Sheets("DEPO").Cells(1, 1) = Format((Son - İlk), "hh:mm:ss.00")
Sheets("DEPO").Cells(1, 2) = "İşlem süresi : " & Format(Timer - Zaman, "0.00000")
  
  'Değişkenleri Boşalt..............................................
SonSatır = Empty: i = Empty: Toplam = Empty
Erase Liste: Erase veri

  
End Sub

Korhan Ayhan Bey ilginize teşekurler aslında soruyu yanlış soruyorum anlaşılan 3 mesajda belirtiğim dosyada bu kodu çalıştırısanız sorun daha net anlaşılacaktır...
Sizin gönderdiginiz kodlarıda deneyerek başka yollar bulmaya çalışıyorum sorun ordan kaynaklanıyor kusura bakmayın.

Korhan Ayhan · 7 Eylül 2016

İlginç bir durum var. Israrla ne yapmak istediğiniz açıklamıyorsunuz.

Ben dosyanızdaki durumu bilemem. Senaryoyu açıklayın ki yardımcı olabilelim.

Eklediğiniz dosyada C1 hücresi boş kod bu durumda nasıl işlem yapacak.

ikikan · 7 Eylül 2016

Korhan Ayhan' Alıntı:
İlginç bir durum var. Israrla ne yapmak istediğiniz açıklamıyorsunuz.

Ben dosyanızdaki durumu bilemem. Senaryoyu açıklayın ki yardımcı olabilelim.

Eklediğiniz dosyada C1 hücresi boş kod bu durumda nasıl işlem yapacak.

Korhan Ayhan Bey; Dosyayı açıklamaı bir şekilde ekledim.Kusura bakmayın tekrar.

ikikan · 10 Eylül 2016

Arkadaşlar ekte gönderdiğim dosya da Filitre yapınca kod çalışmıyor.. nerde hata var ?

Aslında Yapmaya çalıştıgım Farklı bir yötemle Aşagıdaki kodla Korhan Ayhan Bey yapmış fakat ban daha hızlı çalışan bir kod lazım.

Korhan Ayhan' Alıntı:

Alternatif;

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    If Range("A2").Value = "" Then
        ActiveSheet.ShowAllData
        Cells(4, "G") = Cells(4, "E") - Cells(4, "F")
        Son = Cells(Rows.Count, 1).End(3).Row
        With Range("G5:G" & Son)
            .Formula = "=G4+E5-F5"
            .Value = .Value
        End With
    Else
        Range("G4:G" & Rows.Count).ClearContents
        Range("A3:G" & Rows.Count).AutoFilter 1, Range("A2").Value
    
        Bakiye = 0
        Son = Cells(Rows.Count, 1).End(3).Row
    
        For X = 4 To Son
            If Rows(X).RowHeight > 0 Then
                If Cells(X, "A").Value = Range("A2").Value Then
                    Cells(X, "G") = Bakiye + Cells(X, "E") - Cells(X, "F")
                    Bakiye = Cells(X, "G")
                End If
            End If
        Next
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

http://www.excel.web.tr/f48/filtrelenmi-satyrlarda-yuruyen-bakiye-t158632/sayfa2.html

Korhan Ayhan · 10 Eylül 2016

Deneyiniz.

Kod:

Option Explicit

Sub Topla()
    Dim S1 As Worksheet, Dizim(), Veri(), Kriter As Variant
    Dim X As Long, Satir As Long, Zaman As Double, Bakiye As Double
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("DEPO")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
        
    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row
    S1.Range("F5:H" & Satir).Clear
    Veri = S1.Range("A5:C" & Satir).Value
    
    Kriter = S1.Range("C1").Value
    Bakiye = 0
    
    ReDim Dizim(1 To UBound(Veri, 1), 1 To 3)
    
    For X = 1 To UBound(Veri, 1)
        ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 3)
        If Veri(X, 1) = Kriter Then
            Dizim(X, 1) = Bakiye + Veri(X, 2) + Veri(X, 3)
            Bakiye = Dizim(X, 1)
        End If
    Next
    
    S1.Range("H5:H" & UBound(Dizim) + 4) = Dizim
    S1.Range("A4:C" & Satir).AutoFilter 1, Kriter

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    Set S1 = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000"), vbInformation
End Sub

ikikan · 10 Eylül 2016

Korhan Ayhan' Alıntı:

Deneyiniz.

Kod:

Option Explicit

Sub Topla()
    Dim S1 As Worksheet, Dizim(), Veri(), Kriter As Variant
    Dim X As Long, Satir As Long, Zaman As Double, Bakiye As Double
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("DEPO")
    
    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row
    S1.Range("F5:H" & Satir).Clear
    Veri = S1.Range("A5:C" & Satir).Value
    
    Kriter = S1.Range("C1").Value
    Bakiye = 0
    
    ReDim Dizim(1 To UBound(Veri, 1), 1 To 3)
    
    For X = 1 To UBound(Veri, 1)
        ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 3)
        If Veri(X, 1) = Kriter Then
            Dizim(X, 1) = Bakiye + Veri(X, 2) + Veri(X, 3)
            Bakiye = Dizim(X, 1)
        End If
    Next
    
    S1.Range("H5:H" & UBound(Dizim) + 4) = Dizim
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    Set S1 = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000"), vbInformation
End Sub

AutoFilter de çalışmıyor malesef! acaba sebebi nedir? Dizi yöntemi ile otamatik süz bir sorun çıkartıyor.

ikikan · 10 Eylül 2016

Başina: S1.ShowAllData
kodlar...
Sonuna: S1.Range("A5:C" & Rows.Count).AutoFilter 1, Range("C1").Value

Koyunca oldu..

Aslında Korhan Bey diğer konuda bunu uygulamışsınız ordan kopyaladım Teşekürler...

DAHADA kısalırmı bu süre

neyse Abartmayım Çok Teşekürler...

Korhan Ayhan · 10 Eylül 2016

Kaç saniye sürüyor.

ikikan · 10 Eylül 2016

Korhan Ayhan' Alıntı:
Kaç saniye sürüyor.

154638 satır (veride) İşlem süresi : 0,96875 sn

Korhan Ayhan · 10 Eylül 2016

#13 nolu mesajımda ki kodu filtrede çalışacak şekilde düzenledim.

ikikan · 11 Eylül 2016

Korhan Ayhan' Alıntı:

Aşağıdaki kod ise tek sütundaki benzersizleri listelerken ikinci sütundaki verileri toplayarak rapor oluşturur. Yani bir nevi özet tablo gibi çalışır.

Kod:

Sub BENZERSİZ_TEK_SÜTUN_TOPLAMALI()
    Dim s As Object, liste(), dizi()
    
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row
    liste = Sheets(1).Range("a2:b" & Son).Value
    
    ReDim dizi(1 To Son, 1 To 1)
    
    Set s = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(liste, 1)
        Aranan = liste(i, 1)
        If Not s.exists(Aranan) Then
            Say = Say + 1
            s.Add Aranan, Say
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
        End If
        dizi(s.Item(Aranan), 2) = dizi(s.Item(Aranan), 2) + liste(i, 2)
    Next i
    
    Sheets(2).Range("A2").Resize(s.Count, 2) = dizi
End Sub

Korhan Bey vermiş oldugunuz kodlara teşekürler çok işime yaradı. Sadece bilgi amaçlı olarak yukarda yayınladıgınız koduda yaptıgım çalışmada kullanıyorum acaba CreateObject("Scripting.Dictionary") nesnesi ile bu yaptıgımız çalışmaya uygulanırmı amaç sürekli veri hesaplamasını kaldırmak... listedeki benzersizleri bir liste haline getirip bakiye hesaplana bilirmi ? yoksa bu sadece toplam bakiyeleri almak içinmi kullanılır sadec?

ikikan · 7 Mart 2018

Korhan Ayhan' Alıntı:

Deneyiniz.

Kod:

Option Explicit

Sub Topla()
    Dim S1 As Worksheet, Dizim(), Veri(), Kriter As Variant
    Dim X As Long, Satir As Long, Zaman As Double, Bakiye As Double
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("DEPO")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
        
    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row
    S1.Range("F5:H" & Satir).Clear
    Veri = S1.Range("A5:C" & Satir).Value
    
    [COLOR="Red"]Kriter = S1.Range("C1").Value[/COLOR]
    Bakiye = 0
    
    ReDim Dizim(1 To UBound(Veri, 1), 1 To 3)
    
    For X = 1 To UBound(Veri, 1)
        ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 3)
        If Veri(X, 1) = Kriter Then
            Dizim(X, 1) = Bakiye + Veri(X, 2) + Veri(X, 3)
            Bakiye = Dizim(X, 1)
        End If
    Next
    
    S1.Range("H5:H" & UBound(Dizim) + 4) = Dizim
    S1.Range("A4:C" & Satir).AutoFilter 1, Kriter

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    Set S1 = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000"), vbInformation
End Sub

Korhan Beyin 2016 yılında yayınladığı bu koda ilave olarak "Kriter" sayısı artarsa örnek 8 kriterli bir durum olursa "Kriter =S1.Range("A9

9" ).Value" satrında bulunana hücrelerin içine bakarak işlem yapması istenilirse ne gibi bir ekleme yapılmalı dizin komutuna? şimdiden teşekkürler arkadaşlar.

Altalta toplayarak ilerleme

ikikan

Ekli dosyalar

Korhan Ayhan

Administrator

ikikan

Ekli dosyalar

Korhan Ayhan

Administrator

ikikan

Korhan Ayhan

Administrator

ikikan

Korhan Ayhan

Administrator

ikikan

Korhan Ayhan

Administrator

ikikan

Ekli dosyalar

ikikan

Ekli dosyalar

Korhan Ayhan

Administrator

ikikan

ikikan

Korhan Ayhan

Administrator

ikikan

Korhan Ayhan

Administrator

ikikan

ikikan