Macro ile rapor alma

[yyhy]

Macro ile rapor alabilir miyiz?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Rapor_Olustur()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Dizi_A As Object, Dizi_B As Object, Zaman As Double
    Dim Veri As Variant, Son As Long, X As Long
    Dim Yil As Integer, Say_A As Long, Say_B As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Rapor Yıllık")
    Set S3 = Sheets("Rapor Altı Aylık")
    Set Dizi_A = CreateObject("Scripting.Dictionary")
    Set Dizi_B = CreateObject("Scripting.Dictionary")
    
    S2.Range("B3:D" & S2.Rows.Count).Clear
    S3.Range("B3:D" & S3.Rows.Count).Clear
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
    
    Veri = S1.Range("A2:X" & Son).Value2
    
    ReDim Liste_A(1 To Son, 1 To 3)
    ReDim Liste_B(1 To Son, 1 To 3)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Yil = Left(Veri(X, 10), 4)
        If Veri(X, 21) = "Yıllık" Then
            If Not Dizi_A.Exists(Yil) Then
                Say_A = Say_A + 1
                Dizi_A.Add Yil, Say_A
                Liste_A(Say_A, 1) = Yil
                Liste_A(Say_A, 2) = 1
                Liste_A(Say_A, 3) = Veri(X, 10)
            Else
                Liste_A(Dizi_A.Item(Yil), 2) = Liste_A(Dizi_A.Item(Yil), 2) + 1
                Liste_A(Dizi_A.Item(Yil), 3) = Liste_A(Dizi_A.Item(Yil), 3) & ", " & Veri(X, 10)
            End If
        ElseIf Veri(X, 21) = "Altı Aylık" Then
            If Not Dizi_B.Exists(Yil) Then
                Say_B = Say_B + 1
                Dizi_B.Add Yil, Say_B
                Liste_B(Say_B, 1) = Yil
                Liste_B(Say_B, 2) = 1
                Liste_B(Say_B, 3) = Veri(X, 10)
            Else
                Liste_B(Dizi_B.Item(Yil), 2) = Liste_B(Dizi_B.Item(Yil), 2) + 1
                Liste_B(Dizi_B.Item(Yil), 3) = Liste_B(Dizi_B.Item(Yil), 3) & ", " & Veri(X, 10)
            End If
        End If
    Next
    
    If Say_A > 0 Then
        S2.Range("B3").Resize(Say_A, 3) = Liste_A
        S2.Range("B2").Resize(Say_A + 1, 3).Sort S2.Range("B3"), xlAscending, , , , , , xlYes
        S2.Cells.VerticalAlignment = xlCenter
        S2.Range("B3").Resize(Say_A, 2).HorizontalAlignment = xlCenter
        S2.Range("D3").Resize(Say_A, 1).WrapText = True
        S2.Cells(S2.Rows.Count, 3).End(3)(2, 1) = WorksheetFunction.Sum(S2.Range("C3").Resize(Say_A))
        S2.Cells(S2.Rows.Count, 3).End(3).HorizontalAlignment = xlCenter
        S2.Range("B2").Resize(Say_A + 1, 3).Borders.LineStyle = 1
        S2.Cells.EntireRow.AutoFit
    End If
    
    If Say_B > 0 Then
        S3.Range("B3").Resize(Say_B, 3) = Liste_B
        S3.Range("B2").Resize(Say_B + 1, 3).Sort S3.Range("B3"), xlAscending, , , , , , xlYes
        S3.Cells.VerticalAlignment = xlCenter
        S3.Range("B3").Resize(Say_B, 2).HorizontalAlignment = xlCenter
        S3.Range("D3").Resize(Say_B, 1).WrapText = True
        S3.Cells(S3.Rows.Count, 3).End(3)(2, 1) = WorksheetFunction.Sum(S3.Range("C3").Resize(Say_B))
        S3.Cells(S3.Rows.Count, 3).End(3).HorizontalAlignment = xlCenter
        S3.Range("B2").Resize(Say_A + 1, 3).Borders.LineStyle = 1
        S3.Cells.EntireRow.AutoFit
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set Dizi_A = Nothing
    Set Dizi_B = Nothing
    
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
    
    If Say_A > 0 Or Say_B > 0 Then
        MsgBox "Raporlar hazırlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Raporlama için uygun veri bulunamadı!", vbExclamation
    End If
End Sub

 

[yyhy]

Sayın Korhan Ayhan emeğinize sağlık deneyip bilgi vereyim. İyi akşamlar.

 

[yyhy]

Sayın Korhan Bey emeğinize sağlık tam istediğim gibi olmuş. İhtiyaca cevap verdi.