Profosyonellerin işi veri özeti yardımı

[excelience]

Merhaba saygı değer hocalarım
soru ek içinde yer almaktadır biraz karmasık ama soruları acıklayıcı bir sekilde anlattıgımı dusunuyorum
yardımlarınız icin emeginiz icin cok tesekkur ederim hakkınızı helal edin

 

[excelience]

Yardim edebilecek bir hayir sever yok mu

 

[Vedat Özer]

Selamlar,

İadeler'de sıkıntı olursa iade olan rakamları başına - ile girin deneyin.

Option Explicit
Sub OZET1()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
    Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Set S1 = Sheets("Detay")
    Set S2 = Sheets("Özet")
    S2.Range("B8:I" & S2.Rows.Count).ClearContents
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Veri = S1.Range("C8:D" & Son).Value
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For X = 1 To UBound(Veri, 1)
            If Veri(X, 1) <> "" Then
                Kriter = Veri(X, 1)
                If Not IsEmpty(Kriter) Then
                    If Not .Exists(Kriter) Then
                        Say = Say + 1
                        .Add Kriter, Say
                        Liste(Say, 1) = Veri(X, 1)
                    End If
                    On Error Resume Next
                    Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 2)
                    On Error GoTo 0
                End If
            End If
        Next
    End With
    S2.Range("B8").Resize(Say, 2).Value = Liste
    Set S1 = Nothing
    Set S2 = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Call OZET2
    Call OZET3
    Call OZET4
    Call OZET5
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation, "Bilgilendirme"
End Sub
Sub OZET2()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
    Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Set S1 = Sheets("Detay")
    Set S2 = Sheets("Özet")

    Son = S1.Cells(S1.Rows.Count, 6).End(3).Row
    Veri = S1.Range("F8:G" & Son).Value
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For X = 1 To UBound(Veri, 1)
            If Veri(X, 2) <> "" Then
                Kriter = Veri(X, 2)
                If Not IsEmpty(Kriter) Then
                    If Not .Exists(Kriter) Then
                        Say = Say + 1
                        .Add Kriter, Say
                        Liste(Say, 1) = Veri(X, 2)
                    End If
                    On Error Resume Next
                    Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 1)
                    On Error GoTo 0
                End If
            End If
        Next
    End With
    S2.Range("D8").Resize(Say, 2).Value = Liste
    Set S1 = Nothing
    Set S2 = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
Sub OZET3()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
    Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Set S1 = Sheets("Detay")
    Set S2 = Sheets("Özet")

    Son = S1.Cells(S1.Rows.Count, 6).End(3).Row
    Veri = S1.Range("F8:H" & Son).Value
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For X = 1 To UBound(Veri, 1)
            If Veri(X, 3) <> "" Then
                Kriter = Veri(X, 3)
                If Not IsEmpty(Kriter) Then
                    If Not .Exists(Kriter) Then
                        Say = Say + 1
                        .Add Kriter, Say
                        Liste(Say, 1) = Veri(X, 3)
                    End If
                    On Error Resume Next
                    Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 1)
                    On Error GoTo 0
                End If
            End If
        Next
    End With
    S2.Range("F8").Resize(Say, 2).Value = Liste
    Set S1 = Nothing
    Set S2 = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub


Sub OZET4()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
    Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Set S1 = Sheets("Detay")
    Set S2 = Sheets("Özet")

    Son = S1.Cells(S1.Rows.Count, 6).End(3).Row
    Veri = S1.Range("F8:I" & Son).Value
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For X = 1 To UBound(Veri, 1)
            If Veri(X, 4) <> "" Then
                Kriter = Veri(X, 4)
                If Not IsEmpty(Kriter) Then
                    If Not .Exists(Kriter) Then
                        Say = Say + 1
                        .Add Kriter, Say
                        Liste(Say, 1) = Veri(X, 4)
                    End If
                    On Error Resume Next
                    Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 1)
                    On Error GoTo 0
                End If
            End If
        Next
    End With
    S2.Range("H8").Resize(Say, 2).Value = Liste
    Set S1 = Nothing
    Set S2 = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub


Sub OZET5()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
    Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Set S1 = Sheets("Detay")
    Set S2 = Sheets("Özet")

    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    Veri = S1.Range("B8:G" & Son).Value
    ReDim Liste(1 To UBound(Veri, 1), 1 To 3)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For X = 1 To UBound(Veri, 1)
            If Veri(X, 1) <> "" Then
                Kriter = Veri(X, 1) & ":" & Veri(X, 6)
                If Not IsEmpty(Kriter) Then
                    If Not .Exists(Kriter) Then
                        Say = Say + 1
                        .Add Kriter, Say
                        Liste(Say, 1) = Veri(X, 1)
                        Liste(Say, 2) = Veri(X, 6)
                    End If
                    On Error Resume Next
                    Liste(.Item(Kriter), 3) = Liste(.Item(Kriter), 3) + Veri(X, 5)
                    On Error GoTo 0
                End If
            End If
        Next
    End With
    S2.Range("J8").Resize(Say, 3).Value = Liste
    Set S1 = Nothing
    Set S2 = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

 

[excelience]

Vedat hocam cok tesekkurler aksam ilk is kodu deneyecem Allah razi olsun