Ölçütlere göre veri listesini alma

[Vedat Özer]

Merhabalar,

*Cari Kod, Başlangıç Tarihi(>=), (<=)Bitiş Tarihi, Döviz " Evet, Hayır" Evet dediğimizde döviz rakamların gelmesi hayır dediğimizde sütunun boş olması.

*Başlangıç tarihinden önceki günlerin toplamını birinci satıra devir diye yazıp toplamının alınması.

*Veri listelemesi yapılırken Bakiye kısmınında otomatik yazılması.


Veri listemde yaklaşık 90.000 satır mevcut döngü ile işlemimi yapıyorum fakat uzun sürüyo..


CreateObject("Scripting.Dictionary") ile yapmaya çalıştım. Kodun mantığını anlamadığım için yapamadım.


Şimdiden Teşekkür Ederim.

 

[Vedat Özer]

Konu güncelledir.

 

[Korhan Ayhan]

Vedat Bey,

Örnek dosyayı deneyiniz.

Uygulanan kod;

Option Explicit

Sub Ozet_Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Son As Long, Say As Long, Liste(), Veri(), Zaman As Double
    Dim Hesap_Kodu As String, Hesap_Adi As String, Tarih1 As Date, Tarih2 As Date, Doviz As String
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Range("A10:L" & S2.Rows.Count).ClearContents
    S2.Range("A10:A" & S2.Rows.Count).NumberFormat = "dd.mm.yyyy"
    S2.Range("E10:E" & S2.Rows.Count).NumberFormat = "dd.mm.yyyy"
    S2.Range("B10:D" & S2.Rows.Count).NumberFormat = "@"
    S2.Range("G10:L" & S2.Rows.Count).Style = "Comma"
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Say = 1
    
    Liste = S1.Range("A5:L" & Son).Value
    ReDim Veri(1 To Son, 1 To 12)
    
    Hesap_Kodu = S2.Range("B2").Value
    Hesap_Adi = S2.Range("B3").Value
    Tarih1 = S2.Range("B4").Value
    Tarih2 = S2.Range("B5").Value
    Doviz = S2.Range("B6").Value

    Veri(1, 1) = ""
    Veri(1, 2) = ""
    Veri(1, 3) = ""
    Veri(1, 4) = ""
    Veri(1, 5) = ""
    Veri(1, 6) = "Devir"
    Veri(1, 7) = 0
    Veri(1, 8) = 0
    Veri(1, 9) = 0
    Veri(1, 10) = 0
    Veri(1, 11) = 0
    Veri(1, 12) = 0

    For X = LBound(Liste) To UBound(Liste)
        If Liste(X, 1) >= Tarih1 And Liste(X, 1) <= Tarih2 Then
            If Liste(X, 4) = Hesap_Kodu Then
                If Liste(X, 5) = Hesap_Adi Then
                    Say = Say + 1
                    ReDim Preserve Veri(1 To Son, 1 To 12)
                    Veri(Say, 1) = CLng(CDate(Liste(X, 1)))
                    Veri(Say, 2) = Liste(X, 2)
                    Veri(Say, 3) = Liste(X, 3)
                    Veri(Say, 4) = Liste(X, 6)
                    Veri(Say, 5) = CLng(CDate(Liste(X, 7)))
                    Veri(Say, 6) = Liste(X, 8)
                    Veri(Say, 7) = Liste(X, 9)
                    Veri(Say, 8) = Liste(X, 10)
                    Veri(Say, 9) = Veri(Say - 1, 9) + Liste(X, 9) - Liste(X, 10)
                    If Doviz = "Evet" Then
                        Veri(Say, 10) = Liste(X, 11)
                        Veri(Say, 11) = Liste(X, 12)
                        Veri(Say, 12) = Veri(Say - 1, 12) + Liste(X, 11) - Liste(X, 12)
                    Else
                        Veri(Say, 10) = 0
                        Veri(Say, 11) = 0
                        Veri(Say, 12) = 0
                    End If
                End If
            End If
        Else
            If Liste(X, 4) = Hesap_Kodu Then
                If Liste(X, 5) = Hesap_Adi Then
                    Veri(1, 1) = ""
                    Veri(1, 2) = ""
                    Veri(1, 3) = ""
                    Veri(1, 4) = ""
                    Veri(1, 5) = ""
                    Veri(1, 6) = "Devir"
                    Veri(1, 7) = Veri(1, 7) + Liste(X, 9)
                    Veri(1, 8) = Veri(1, 8) + Liste(X, 10)
                    Veri(1, 9) = Veri(1, 7) - Veri(1, 8)
                    If Doviz = "Evet" Then
                        Veri(1, 10) = Veri(1, 10) + Liste(X, 11)
                        Veri(1, 11) = Veri(1, 11) + Liste(X, 12)
                        Veri(1, 12) = Veri(1, 10) - Veri(1, 11)
                    Else
                        Veri(1, 10) = 0
                        Veri(1, 11) = 0
                        Veri(1, 12) = 0
                    End If
                End If
            End If
        End If
    Next

    If Say > 0 Then
        S2.Range("A10").Resize(Say, 12) = Veri
        S2.Range("A:L").EntireColumn.AutoFit
    End If

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

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

 

[Vedat Özer]

Merhabalar,

Korhan bey,

İlginiz için teşekkür ederim.