• DİKKAT

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

KOŞULLU VERİ TOPLAMI

MehmetSincap

MehmetSincap

Katılım
27 Kasım 2019
Mesajlar
44
Excel Vers. ve Dili
excell
Merhaba,

Ekte yer alan excellde koşullu veri toplama yapılmaktadır fakat veri arttıkça dosya hızı yavaşlıyor. Makro yazılabilir mi?,

saygılar.
 

Ekli dosyalar

C-H sütunları arasındaki 4. ve 5. satırdaki formülleriniz farklı görünüyor. Bir hata olabilir mi?
 
Örnek çalışmayı inceleyiniz. Kod yazınımda kolaylık sağlaması açısından C2 C3 C4 , D2 D3 D4 ... hücrelerine formülde kullanılan kısaltmaları ilave ettim.
Bir tek PEŞİN, I, C, D Kısaltması 4 koşuldan oluştuğu için farklı. Umarım yanlış değildir. :|
 

Ekli dosyalar

Alternatif;

Süre olarak daha iyi performans verecektir.

Kod: 
Option Explicit

Sub Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Dizi As Object
    Dim Son As Long, Son_P As Long, Veri_P As Variant, Aranan As String
    Dim Son_T As Long, Veri_T As Variant, Zaman As Double
    Dim X As Long, Y As Byte, Say As Long
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("VERİ-T")
    Set S2 = Sheets("VERİ-P")
    Set S3 = Sheets("TEKİL")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
   
    'PEŞİN BÖLÜMÜ İŞLEMLERİ
    Son_P = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Veri_P = S2.Range("A2:F" & Son_P).Value
   
    For X = 1 To UBound(Veri_P)
        If Veri_P(X, 4) = "I" Then
            If Veri_P(X, 5) = "C" Or Veri_P(X, 5) = "D" Then
                Aranan = Veri_P(X, 1) & "#" & Veri_P(X, 2) & "#" & Veri_P(X, 3) & "#" & Veri_P(X, 4) & "#" & "C-D"
            Else
                Aranan = Veri_P(X, 1) & "#" & Veri_P(X, 2) & "#" & Veri_P(X, 3) & "#" & Veri_P(X, 4) & "#" & Veri_P(X, 5)
            End If
        Else
            Aranan = Veri_P(X, 1) & "#" & Veri_P(X, 2) & "#" & Veri_P(X, 3) & "#" & Veri_P(X, 4) & "#" & Veri_P(X, 5)
        End If
       
        If Not Dizi.Exists(Aranan) Then
            Dizi.Item(Aranan) = Veri_P(X, 6)
        Else
            Dizi.Item(Aranan) = Dizi.Item(Aranan) + Veri_P(X, 6)
        End If
    Next
   
    Son = S3.Cells(S3.Rows.Count, 2).End(3).Row
   
    ReDim Liste(1 To Son, 1 To 7)
    Say = 0
   
    For X = 4 To Son
        Say = Say + 1
        For Y = 3 To 8
            Select Case Y
                Case 3
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "O" & "#" & "C"
                Case 4
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "TAKSITLI" & "#" & "O" & "#" & "C"
                Case 5
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "D" & "#" & "C"
                Case 6
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "O" & "#" & "D"
                Case 7
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "D" & "#" & "D"
                Case 8
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "I" & "#" & "C-D"
            End Select
               
            If Dizi.Exists(Aranan) Then
                Liste(Say, Y - 2) = Dizi.Item(Aranan)
            Else
                Liste(Say, Y - 2) = 0
            End If
       
            Liste(Say, 7) = Liste(Say, 7) + Dizi.Item(Aranan)
        Next
    Next

    S3.Range("C4").Resize(Son, 7) = Liste


    'TAKSİT BÖLÜMÜ İŞLEMLERİ
    Son_T = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri_T = S1.Range("A2:D" & Son_T).Value
   
    For X = 1 To UBound(Veri_T)
        Aranan = Veri_T(X, 1) & "#" & Veri_T(X, 2) & "#" & Veri_T(X, 3)
       
        If Not Dizi.Exists(Aranan) Then
            Dizi.Item(Aranan) = Veri_T(X, 4)
        Else
            Dizi.Item(Aranan) = Dizi.Item(Aranan) + Veri_T(X, 4)
        End If
    Next
   
    Son = S3.Cells(S3.Rows.Count, 2).End(3).Row
   
    ReDim Liste(1 To Son, 1 To 12)
    Say = 0
   
    For X = 4 To Son
        Say = Say + 1
        For Y = 10 To 20
            Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & S3.Cells(3, Y)
               
            If Dizi.Exists(Aranan) Then
                Liste(Say, Y - 9) = Dizi.Item(Aranan)
            Else
                Liste(Say, Y - 9) = 0
            End If
       
            Liste(Say, 12) = Liste(Say, 12) + Dizi.Item(Aranan)
        Next
    Next

    S3.Range("J4").Resize(Son, 12) = Liste

    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif;

Süre olarak daha iyi performans verecektir.

Kod: 
Option Explicit

Sub Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Dizi As Object
    Dim Son As Long, Son_P As Long, Veri_P As Variant, Aranan As String
    Dim Son_T As Long, Veri_T As Variant, Zaman As Double
    Dim X As Long, Y As Byte, Say As Long
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Set S1 = Sheets("VERİ-T")
    Set S2 = Sheets("VERİ-P")
    Set S3 = Sheets("TEKİL")
    Set Dizi = CreateObject("Scripting.Dictionary")
  
  
    'PEŞİN BÖLÜMÜ İŞLEMLERİ
    Son_P = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Veri_P = S2.Range("A2:F" & Son_P).Value
  
    For X = 1 To UBound(Veri_P)
        If Veri_P(X, 4) = "I" Then
            If Veri_P(X, 5) = "C" Or Veri_P(X, 5) = "D" Then
                Aranan = Veri_P(X, 1) & "#" & Veri_P(X, 2) & "#" & Veri_P(X, 3) & "#" & Veri_P(X, 4) & "#" & "C-D"
            Else
                Aranan = Veri_P(X, 1) & "#" & Veri_P(X, 2) & "#" & Veri_P(X, 3) & "#" & Veri_P(X, 4) & "#" & Veri_P(X, 5)
            End If
        Else
            Aranan = Veri_P(X, 1) & "#" & Veri_P(X, 2) & "#" & Veri_P(X, 3) & "#" & Veri_P(X, 4) & "#" & Veri_P(X, 5)
        End If
      
        If Not Dizi.Exists(Aranan) Then
            Dizi.Item(Aranan) = Veri_P(X, 6)
        Else
            Dizi.Item(Aranan) = Dizi.Item(Aranan) + Veri_P(X, 6)
        End If
    Next
  
    Son = S3.Cells(S3.Rows.Count, 2).End(3).Row
  
    ReDim Liste(1 To Son, 1 To 7)
    Say = 0
  
    For X = 4 To Son
        Say = Say + 1
        For Y = 3 To 8
            Select Case Y
                Case 3
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "O" & "#" & "C"
                Case 4
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "TAKSITLI" & "#" & "O" & "#" & "C"
                Case 5
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "D" & "#" & "C"
                Case 6
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "O" & "#" & "D"
                Case 7
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "D" & "#" & "D"
                Case 8
                Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & "PESIN" & "#" & "I" & "#" & "C-D"
            End Select
              
            If Dizi.Exists(Aranan) Then
                Liste(Say, Y - 2) = Dizi.Item(Aranan)
            Else
                Liste(Say, Y - 2) = 0
            End If
      
            Liste(Say, 7) = Liste(Say, 7) + Dizi.Item(Aranan)
        Next
    Next

    S3.Range("C4").Resize(Son, 7) = Liste


    'TAKSİT BÖLÜMÜ İŞLEMLERİ
    Son_T = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri_T = S1.Range("A2:D" & Son_T).Value
  
    For X = 1 To UBound(Veri_T)
        Aranan = Veri_T(X, 1) & "#" & Veri_T(X, 2) & "#" & Veri_T(X, 3)
      
        If Not Dizi.Exists(Aranan) Then
            Dizi.Item(Aranan) = Veri_T(X, 4)
        Else
            Dizi.Item(Aranan) = Dizi.Item(Aranan) + Veri_T(X, 4)
        End If
    Next
  
    Son = S3.Cells(S3.Rows.Count, 2).End(3).Row
  
    ReDim Liste(1 To Son, 1 To 12)
    Say = 0
  
    For X = 4 To Son
        Say = Say + 1
        For Y = 10 To 20
            Aranan = S3.Cells(3, 2) & "#" & S3.Cells(X, 2) & "#" & S3.Cells(3, Y)
              
            If Dizi.Exists(Aranan) Then
                Liste(Say, Y - 9) = Dizi.Item(Aranan)
            Else
                Liste(Say, Y - 9) = 0
            End If
      
            Liste(Say, 12) = Liste(Say, 12) + Dizi.Item(Aranan)
        Next
    Next

    S3.Range("J4").Resize(Son, 12) = Liste

    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...

Hocam çok teşekkür ederim. Kusursuz performans.

Ellerine sağlık.

Çözüldü.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst