Attribute VB_Name = "RaporModulu"
'=====================================================================
' Aylik Satis Raporu Otomasyonu
' Ozgur Nurettin Ozturk - ozgurnurettinozturk.com
'
' Ne yapar?
'   1) Ayarlar sayfasindaki kaynak dosyayi (Online Retail II) salt okunur acar,
'      tum satirlari tek seferde diziye alir ve dosyayi kapatir.
'   2) Her satiri siniflandirir: satis, iade (C ile baslayan fatura),
'      hizmet kodu (kargo, banka masrafi...), gecersiz (miktar/fiyat <= 0).
'   3) Ay bazinda brut satis, iade, net satis, siparis, musteri, sepet
'      ortalamasi, gunluk seri, en cok satan urunler ve ulkeler hesaplar.
'   4) "Rapor" sayfasini sifirdan kurar (KPI kartlari, tablolar, 2 grafik)
'      ve istenirse PDF olarak kaydeder.
'   5) Her calismayi "Log" sayfasina yazar (satir sayilari, sure).
'
' Makrolar:
'   RaporOlustur  -> Ayarlar!B5'teki ay icin tek rapor
'   TumAylar      -> verideki her ay icin ayri PDF (veri bir kez okunur)
'=====================================================================
Option Explicit

Private Const SH_SET As String = "Ayarlar"
Private Const SH_REP As String = "Rapor"
Private Const SH_LOG As String = "Log"

' ay bazli toplamlar (anahtar: YYYYMM)
Private mBrut As Object, mIade As Object, mInv As Object, mCust As Object
Private mDay As Object, mProd As Object, mCtry As Object, mDesc As Object
Private nRows As Long, nSale As Long, nRet As Long, nSvc As Long, nBad As Long
Private tLoad As Double

'---------------------------------------------------------------------
Public Sub RaporOlustur()
    Dim t0 As Double: t0 = Timer
    Dim mk As Long
    On Error GoTo Fail
    If Not LoadAndProcess() Then GoTo Done
    mk = MonthKeyFromSetting()
    If Not mBrut.Exists(mk) Then
        MsgBox "Secilen ay veride yok: " & mk, vbExclamation
        GoTo Done
    End If
    BuildReport mk
    ExportPdf mk
    WriteLog "RaporOlustur", CStr(mk), Timer - t0
Done:
    AppOn
    Exit Sub
Fail:
    AppOn
    MsgBox "Hata: " & Err.Description, vbCritical
End Sub

Public Sub TumAylar()
    Dim t0 As Double: t0 = Timer
    Dim k As Variant, n As Long
    On Error GoTo Fail
    If Not LoadAndProcess() Then AppOn: Exit Sub
    For Each k In SortedKeys(mBrut)
        BuildReport CLng(k)
        ExportPdf CLng(k)
        n = n + 1
        Application.StatusBar = "Rapor hazirlaniyor: " & k
    Next k
    WriteLog "TumAylar", n & " ay", Timer - t0
    AppOn
    ThisWorkbook.Worksheets(SH_REP).Activate
    MsgBox n & " aylik rapor hazirlandi (" & Format(Timer - t0, "0.0") & " sn).", vbInformation
    Exit Sub
Fail:
    AppOn
    MsgBox "Hata: " & Err.Description, vbCritical
End Sub

'---------------------------------------------------------------------
' Veriyi oku ve tek geciste tum toplamlari hesapla
'---------------------------------------------------------------------
Private Function LoadAndProcess() As Boolean
    Dim ws As Worksheet, src As String, sheetName As String
    Dim wb As Workbook, arr As Variant, t As Double
    Set ws = ThisWorkbook.Worksheets(SH_SET)
    src = Trim$(CStr(ws.Range("B3").Value))
    sheetName = Trim$(CStr(ws.Range("B4").Value))
    If Len(Dir$(src)) = 0 Or Len(src) = 0 Then
        MsgBox "Kaynak dosya bulunamadi:" & vbCrLf & src, vbCritical
        Exit Function
    End If

    AppOff
    t = Timer
    Application.StatusBar = "Kaynak dosya aciliyor..."
    Set wb = Workbooks.Open(Filename:=src, ReadOnly:=True, UpdateLinks:=False)
    arr = wb.Worksheets(sheetName).UsedRange.Value
    wb.Close SaveChanges:=False
    tLoad = Timer - t

    Application.StatusBar = "Satirlar isleniyor..."
    ProcessArray arr
    LoadAndProcess = True
End Function

Private Sub ProcessArray(arr As Variant)
    Dim cInv As Long, cCode As Long, cDesc As Long, cQty As Long
    Dim colDate As Long, cPrice As Long, cCust As Long, cCtry As Long
    Dim r As Long, j As Long, h As String
    Dim inv As String, code As String, qty As Double, price As Double
    Dim dt As Date, mk As Long, amt As Double, cust As String, ctry As String

    For j = 1 To UBound(arr, 2)
        h = LCase$(Trim$(CStr(arr(1, j))))
        Select Case h
            Case "invoice", "invoiceno": cInv = j
            Case "stockcode": cCode = j
            Case "description": cDesc = j
            Case "quantity": cQty = j
            Case "invoicedate": colDate = j
            Case "price", "unitprice": cPrice = j
            Case "customer id", "customerid": cCust = j
            Case "country": cCtry = j
        End Select
    Next j
    If cInv * cCode * cQty * colDate * cPrice * cCust * cCtry = 0 Then
        Err.Raise vbObjectError + 1, , "Beklenen sutun basliklari bulunamadi."
    End If

    Set mBrut = NewDict(): Set mIade = NewDict(): Set mInv = NewDict()
    Set mCust = NewDict(): Set mDay = NewDict(): Set mProd = NewDict()
    Set mCtry = NewDict(): Set mDesc = NewDict()
    nRows = 0: nSale = 0: nRet = 0: nSvc = 0: nBad = 0

    For r = 2 To UBound(arr, 1)
        If Not IsEmpty(arr(r, cInv)) Then
            nRows = nRows + 1
            inv = UCase$(Trim$(CStr(arr(r, cInv))))
            code = UCase$(Trim$(CStr(arr(r, cCode))))
            qty = Num(arr(r, cQty)): price = Num(arr(r, cPrice))
            dt = CDate(arr(r, colDate))
            mk = CLng(Year(dt)) * 100 + Month(dt)
            amt = qty * price

            If IsServiceCode(code) Then
                nSvc = nSvc + 1
            ElseIf Left$(inv, 1) = "C" Then
                nRet = nRet + 1
                AddNum mIade, mk, -amt
                AddNum Sub2(mDay, mk), Day(dt), amt          ' iade gunluk netten duser
            ElseIf Left$(inv, 1) = "A" Or qty <= 0 Or price <= 0 Then
                nBad = nBad + 1
            Else
                nSale = nSale + 1
                AddNum mBrut, mk, amt
                AddNum Sub2(mDay, mk), Day(dt), amt
                Sub2(mInv, mk).Item(inv) = 1
                cust = Trim$(CStr(arr(r, cCust)))
                If Len(cust) > 0 Then Sub2(mCust, mk).Item(cust) = 1
                AddNum Sub2(mProd, mk), code, amt
                ctry = Trim$(CStr(arr(r, cCtry)))
                AddNum Sub2(mCtry, mk), ctry, amt
                If cDesc > 0 Then
                    If Not mDesc.Exists(code) Then mDesc(code) = Trim$(CStr(arr(r, cDesc)))
                End If
            End If
        End If
    Next r
    ' iade olup satisi olmayan ay olmasin diye
    Dim k As Variant
    For Each k In mIade.Keys
        If Not mBrut.Exists(k) Then mBrut(k) = 0#
    Next k
End Sub

Private Function IsServiceCode(ByVal code As String) As Boolean
    Select Case code
        Case "POST", "DOT", "M", "C2", "D", "S", "AMAZONFEE", "BANK CHARGES", "CRUK", "PADS", "B"
            IsServiceCode = True
        Case Else
            IsServiceCode = (Left$(code, 6) = "ADJUST" Or Left$(code, 4) = "TEST")
    End Select
End Function

'---------------------------------------------------------------------
' Rapor sayfasi
'---------------------------------------------------------------------
Private Sub BuildReport(ByVal mk As Long)
    Dim ws As Worksheet, pk As Long, r As Long, i As Long
    Dim brut As Double, iade As Double, ordersN As Long, custN As Long
    Dim pb As Double, pi As Double, po As Long, pc As Long, hasPrev As Boolean

    Set ws = FreshSheet(SH_REP)
    ActiveWindow.DisplayGridlines = False
    ws.Cells.Font.Name = "Calibri": ws.Cells.Font.Size = 10
    ws.Columns("A").ColumnWidth = 2
    ws.Columns("B:J").ColumnWidth = 16

    pk = PrevKey(mk): hasPrev = mBrut.Exists(pk)
    brut = mBrut(mk): iade = GetNum(mIade, mk)
    ordersN = Sub2(mInv, mk).Count: custN = Sub2(mCust, mk).Count
    If hasPrev Then pb = mBrut(pk): pi = GetNum(mIade, pk): po = Sub2(mInv, pk).Count: pc = Sub2(mCust, pk).Count

    ' baslik
    With ws.Range("B2")
        .Value = U("Ayl\u0131k Sat\u0131\u015F Raporu \u2014 ") & MonthName2(mk)
        .Font.Size = 18: .Font.Bold = True: .Font.Color = RGB(31, 41, 55)
    End With
    ws.Range("B3").Value = "Kaynak: " & ThisWorkbook.Worksheets(SH_SET).Range("B3").Value & _
        U("   |   Olu\u015Fturma: ") & Format(Now, "dd.mm.yyyy hh:nn")
    ws.Range("B3").Font.Color = RGB(107, 114, 128)

    ' KPI kartlari: etiket / deger / onceki aya gore degisim
    Dim lab, vals, prevs, fmts
    lab = Array(U("Net sat\u0131\u015F"), U("Br\u00FCt sat\u0131\u015F"), U("\u0130ade"), U("Sipari\u015F"), U("M\u00FC\u015Fteri"), "Ort. sepet")
    vals = Array(brut - iade, brut, iade, ordersN, custN, SafeDiv(brut, ordersN))
    prevs = Array(pb - pi, pb, pi, po, pc, SafeDiv(pb, po))
    fmts = Array(U("\u00A3#,##0"), U("\u00A3#,##0"), U("\u00A3#,##0"), "#,##0", "#,##0", U("\u00A3#,##0.00"))
    For i = 0 To 5
        KpiCard ws, 5, KpiCol(i), CStr(lab(i)), CDbl(vals(i)), CDbl(prevs(i)), CStr(fmts(i)), hasPrev, (i = 2)
    Next i

    ' gunluk net satis tablosu (grafik kaynagi)
    r = 10
    ws.Cells(r, 2).Value = U("G\u00FCnl\u00FCk net sat\u0131\u015F"): ws.Cells(r, 2).Font.Bold = True
    ws.Cells(r + 1, 2).Value = U("G\u00FCn"): ws.Cells(r + 1, 3).Value = U("Net sat\u0131\u015F (\u00A3)")
    HeaderStyle ws.Range(ws.Cells(r + 1, 2), ws.Cells(r + 1, 3))
    Dim dk As Variant, dd As Object, n As Long
    Set dd = Sub2(mDay, mk)
    n = 0
    For Each dk In SortedKeys(dd)
        n = n + 1
        ws.Cells(r + 1 + n, 2).Value = CLng(dk)
        ws.Cells(r + 1 + n, 3).Value = dd(dk)
    Next dk
    ws.Range(ws.Cells(r + 2, 3), ws.Cells(r + 1 + n, 3)).NumberFormat = "#,##0"
    AddChart ws, ws.Range(ws.Cells(r + 2, 2), ws.Cells(r + 1 + n, 2)), ws.Range(ws.Cells(r + 2, 3), ws.Cells(r + 1 + n, 3)), _
        ws.Cells(10, 5), ws.Cells(1, 11).Left - ws.Cells(10, 5).Left, 210, U("G\u00FCnl\u00FCk net sat\u0131\u015F (\u00A3)"), xlColumnClustered

    ' en cok satan 10 urun
    Dim top As Variant, rr As Long
    rr = r + 3 + n + 1
    rr = Application.WorksheetFunction.Max(rr, 27)
    ws.Cells(rr, 2).Value = U("En \u00E7ok satan 10 \u00FCr\u00FCn"): ws.Cells(rr, 2).Font.Bold = True
    ws.Cells(rr + 1, 2).Value = "Stok kodu": ws.Cells(rr + 1, 3).Value = U("\u00DCr\u00FCn"): ws.Cells(rr + 1, 6).Value = U("Br\u00FCt sat\u0131\u015F (\u00A3)"): ws.Cells(rr + 1, 7).Value = "Pay"
    HeaderStyle ws.Range(ws.Cells(rr + 1, 2), ws.Cells(rr + 1, 7))
    top = TopN(Sub2(mProd, mk), 10)
    For i = 1 To UBound(top, 1)
        ws.Cells(rr + 1 + i, 2).NumberFormat = "@"
        ws.Cells(rr + 1 + i, 2).Value = CStr(top(i, 1))
        ws.Cells(rr + 1 + i, 2).Errors(xlNumberAsText).Ignore = True
        If mDesc.Exists(top(i, 1)) Then ws.Cells(rr + 1 + i, 3).Value = mDesc(top(i, 1))
        ws.Range(ws.Cells(rr + 1 + i, 3), ws.Cells(rr + 1 + i, 5)).Merge
        ws.Cells(rr + 1 + i, 6).Value = top(i, 2)
        ws.Cells(rr + 1 + i, 7).Value = SafeDiv(CDbl(top(i, 2)), brut)
    Next i
    ws.Range(ws.Cells(rr + 2, 6), ws.Cells(rr + 11, 6)).NumberFormat = "#,##0"
    ws.Range(ws.Cells(rr + 2, 7), ws.Cells(rr + 11, 7)).NumberFormat = "0.0%"

    ' ulkeler (Birlesik Krallik haric grafik)
    Dim cr As Long
    cr = rr + 14
    ws.Cells(cr, 2).Value = U("\u00DClkelere g\u00F6re br\u00FCt sat\u0131\u015F"): ws.Cells(cr, 2).Font.Bold = True
    ws.Cells(cr + 1, 2).Value = U("\u00DClke"): ws.Cells(cr + 1, 3).Value = U("Br\u00FCt sat\u0131\u015F (\u00A3)"): ws.Cells(cr + 1, 4).Value = "Pay"
    HeaderStyle ws.Range(ws.Cells(cr + 1, 2), ws.Cells(cr + 1, 4))
    top = TopN(Sub2(mCtry, mk), 10)
    For i = 1 To UBound(top, 1)
        ws.Cells(cr + 1 + i, 2).Value = top(i, 1)
        ws.Cells(cr + 1 + i, 3).Value = top(i, 2)
        ws.Cells(cr + 1 + i, 4).Value = SafeDiv(CDbl(top(i, 2)), brut)
    Next i
    ws.Range(ws.Cells(cr + 2, 3), ws.Cells(cr + 11, 3)).NumberFormat = "#,##0"
    ws.Range(ws.Cells(cr + 2, 4), ws.Cells(cr + 11, 4)).NumberFormat = "0.0%"
    Dim f0 As Long, ttl As String
    f0 = 2: ttl = U("\u00DClkelere g\u00F6re br\u00FCt sat\u0131\u015F (\u00A3)")
    If CStr(top(1, 1)) = "United Kingdom" Then f0 = 3: ttl = U("Birle\u015Fik Krall\u0131k d\u0131\u015F\u0131ndaki \u00FClkeler (\u00A3)")
    If UBound(top, 1) >= f0 Then
        AddChart ws, ws.Range(ws.Cells(cr + f0, 2), ws.Cells(cr + 1 + UBound(top, 1), 2)), _
            ws.Range(ws.Cells(cr + f0, 3), ws.Cells(cr + 1 + UBound(top, 1), 3)), _
            ws.Cells(cr, 6), ws.Cells(1, 11).Left - ws.Cells(cr, 6).Left, 220, ttl, xlBarClustered
    End If

    ' not
    ws.Cells(cr + 17, 2).Value = U("Not: Br\u00FCt sat\u0131\u015F iptal (C) faturalar\u0131, kargo/banka gibi hizmet kodlar\u0131n\u0131 ve miktar\u0131 ya da fiyat\u0131 s\u0131f\u0131r olan sat\u0131rlar\u0131 i\u00E7ermez. \u0130ade, ayn\u0131 aydaki iptal faturalar\u0131n\u0131n tutar\u0131d\u0131r.")
    ws.Cells(cr + 17, 2).Font.Color = RGB(107, 114, 128): ws.Cells(cr + 17, 2).Font.Italic = True

    ' sayfa duzeni
    With ws.PageSetup
        .Orientation = xlPortrait
        .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 1
        .PrintArea = ws.Range(ws.Cells(1, 1), ws.Cells(cr + 18, 10)).Address
        .CenterHorizontally = True
        .LeftMargin = Application.CentimetersToPoints(1): .RightMargin = Application.CentimetersToPoints(1)
        .TopMargin = Application.CentimetersToPoints(1): .BottomMargin = Application.CentimetersToPoints(1)
    End With
End Sub

Private Function KpiCol(ByVal i As Long) As Long
    KpiCol = 2 + i
End Function

Private Sub KpiCard(ws As Worksheet, ByVal r As Long, ByVal c As Long, ByVal lab As String, ByVal v As Double, ByVal p As Double, _
                    ByVal fmt As String, ByVal hasPrev As Boolean, ByVal lowerIsBetter As Boolean)
    Dim rng As Range, ch As Double
    Set rng = ws.Range(ws.Cells(r, c), ws.Cells(r + 2, c))
    rng.Interior.Color = RGB(243, 244, 246)
    rng.Borders(xlEdgeLeft).Color = RGB(124, 58, 237): rng.Borders(xlEdgeLeft).Weight = xlThick
    ws.Cells(r, c).Value = lab: ws.Cells(r, c).Font.Color = RGB(107, 114, 128)
    ws.Cells(r + 1, c).Value = v: ws.Cells(r + 1, c).NumberFormat = fmt
    ws.Cells(r + 1, c).Font.Size = 14: ws.Cells(r + 1, c).Font.Bold = True
    If hasPrev And p <> 0 Then
        ch = v / p - 1
        ws.Cells(r + 2, c).Value = ch
        ws.Cells(r + 2, c).NumberFormat = "+0.0%;-0.0%;0.0%"
        If (ch >= 0) Xor lowerIsBetter Then
            ws.Cells(r + 2, c).Font.Color = RGB(22, 163, 74)
        Else
            ws.Cells(r + 2, c).Font.Color = RGB(220, 38, 38)
        End If
    Else
        ws.Cells(r + 2, c).Value = U("\u00F6nceki ay yok")
        ws.Cells(r + 2, c).Font.Color = RGB(156, 163, 175)
    End If
End Sub

Private Sub HeaderStyle(rng As Range)
    rng.Font.Bold = True
    rng.Interior.Color = RGB(237, 233, 254)
    rng.Borders(xlEdgeBottom).Color = RGB(124, 58, 237)
End Sub

Private Sub AddChart(ws As Worksheet, xr As Range, yr As Range, anchor As Range, ByVal w As Double, ByVal h As Double, _
                     ByVal ttl As String, ByVal kind As Long)
    Dim co As ChartObject
    Set co = ws.ChartObjects.Add(anchor.Left, anchor.Top, w, h)
    With co.Chart
        .ChartType = kind
        Do While .SeriesCollection.Count > 0: .SeriesCollection(1).Delete: Loop
        With .SeriesCollection.NewSeries
            .XValues = xr: .Values = yr
            .Format.Fill.ForeColor.RGB = RGB(124, 58, 237)
        End With
        .HasTitle = True: .ChartTitle.Text = ttl: .ChartTitle.Font.Size = 11
        .HasLegend = False
        .Axes(xlValue).HasMajorGridlines = True
        .Axes(xlValue).MajorGridlines.Format.Line.ForeColor.RGB = RGB(229, 231, 235)
        .Axes(xlValue).TickLabels.NumberFormatLinked = True
        If kind = xlBarClustered Then .Axes(xlCategory).ReversePlotOrder = True
        .ChartGroups(1).GapWidth = 60
    End With
End Sub

Private Sub ExportPdf(ByVal mk As Long)
    Dim folder As String, f As String
    folder = Trim$(CStr(ThisWorkbook.Worksheets(SH_SET).Range("B6").Value))
    If Len(folder) = 0 Then Exit Sub
    If Right$(folder, 1) <> "\" Then folder = folder & "\"
    If Len(Dir$(folder, vbDirectory)) = 0 Then MkDir folder
    f = folder & "Satis_Raporu_" & Left$(CStr(mk), 4) & "-" & Right$(CStr(mk), 2) & ".pdf"
    ThisWorkbook.Worksheets(SH_REP).ExportAsFixedFormat Type:=xlTypePDF, Filename:=f, _
        Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

Private Sub WriteLog(ByVal what As String, ByVal detail As String, ByVal secs As Double)
    Dim ws As Worksheet, r As Long
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(SH_LOG)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        ws.Name = SH_LOG
        ws.Range("A1:J1").Value = Array("Zaman", "Makro", "Ay", U("Okunan sat\u0131r"), U("Sat\u0131\u015F"), U("\u0130ade"), "Hizmet kodu", U("Ge\u00E7ersiz"), "Okuma (sn)", "Toplam (sn)")
        ws.Range("A1:J1").Font.Bold = True
    End If
    r = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    ws.Range(ws.Cells(r, 1), ws.Cells(r, 10)).Value = Array(Now, what, detail, nRows, nSale, nRet, nSvc, nBad, Round(tLoad, 1), Round(secs, 1))
    ws.Cells(r, 1).NumberFormat = "dd.mm.yyyy hh:mm:ss"
    ws.Columns("A:J").AutoFit
End Sub

'---------------------------------------------------------------------
' Yardimcilar
'---------------------------------------------------------------------
Private Function U(ByVal s As String) As String
    ' \uXXXX kacislarini Unicode karaktere cevirir (modul dosyasi ASCII kalsin diye)
    Dim i As Long, out As String
    i = 1
    Do While i <= Len(s)
        If Mid$(s, i, 2) = "\u" And i + 5 <= Len(s) Then
            out = out & ChrW(CLng("&H" & Mid$(s, i + 2, 4))): i = i + 6
        Else
            out = out & Mid$(s, i, 1): i = i + 1
        End If
    Loop
    U = out
End Function

Private Function NewDict() As Object
    Set NewDict = CreateObject("Scripting.Dictionary")
    NewDict.CompareMode = vbBinaryCompare
End Function

Private Function Sub2(parent As Object, ByVal k As Variant) As Object
    If Not parent.Exists(k) Then parent.Add k, NewDict()
    Set Sub2 = parent(k)
End Function

Private Sub AddNum(d As Object, ByVal k As Variant, ByVal v As Double)
    If d.Exists(k) Then d(k) = d(k) + v Else d.Add k, v
End Sub

Private Function GetNum(d As Object, ByVal k As Variant) As Double
    If d.Exists(k) Then GetNum = d(k)
End Function

Private Function Num(ByVal v As Variant) As Double
    If IsNumeric(v) Then Num = CDbl(v)
End Function

Private Function SafeDiv(ByVal a As Double, ByVal b As Double) As Double
    If b <> 0 Then SafeDiv = a / b
End Function

Private Function PrevKey(ByVal mk As Long) As Long
    If mk Mod 100 = 1 Then PrevKey = (mk \ 100 - 1) * 100 + 12 Else PrevKey = mk - 1
End Function

Private Function MonthKeyFromSetting() As Long
    Dim v As Variant
    v = ThisWorkbook.Worksheets(SH_SET).Range("B5").Value
    If IsDate(v) Then
        MonthKeyFromSetting = CLng(Year(CDate(v))) * 100 + Month(CDate(v))
    Else
        MonthKeyFromSetting = CLng(Replace(Replace(CStr(v), "-", ""), ".", ""))
    End If
End Function

Private Function MonthName2(ByVal mk As Long) As String
    Dim names
    names = Array("Ocak", U("\u015Eubat"), "Mart", "Nisan", U("May\u0131s"), "Haziran", "Temmuz", U("A\u011Fustos"), U("Eyl\u00FCl"), "Ekim", U("Kas\u0131m"), U("Aral\u0131k"))
    MonthName2 = names((mk Mod 100) - 1) & " " & (mk \ 100)
End Function

Private Function SortedKeys(d As Object) As Variant
    Dim a() As Variant, i As Long, j As Long, t As Variant
    If d.Count = 0 Then SortedKeys = Array(): Exit Function
    a = d.Keys
    For i = LBound(a) To UBound(a) - 1
        For j = i + 1 To UBound(a)
            If a(j) < a(i) Then t = a(i): a(i) = a(j): a(j) = t
        Next j
    Next i
    SortedKeys = a
End Function

Private Function TopN(d As Object, ByVal n As Long) As Variant
    ' d: anahtar -> tutar ; en buyuk n tanesini (anahtar, tutar) dizisi olarak dondurur
    Dim k As Variant, out() As Variant, m As Long, i As Long, j As Long
    m = IIf(d.Count < n, d.Count, n)
    If m = 0 Then
        ReDim out(1 To 1, 1 To 2): TopN = out: Exit Function
    End If
    ReDim out(1 To m, 1 To 2)
    For Each k In d.Keys
        For i = 1 To m
            If IsEmpty(out(i, 1)) Or d(k) > out(i, 2) Then
                For j = m To i + 1 Step -1
                    out(j, 1) = out(j - 1, 1): out(j, 2) = out(j - 1, 2)
                Next j
                out(i, 1) = k: out(i, 2) = d(k)
                Exit For
            End If
        Next i
    Next k
    TopN = out
End Function

Private Function FreshSheet(nm As String) As Worksheet
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets(nm).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(SH_SET))
    ws.Name = nm
    ws.Activate
    Set FreshSheet = ws
End Function

Private Sub AppOff()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
End Sub

Private Sub AppOn()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.StatusBar = False
End Sub