Attribute VB_Name = "Modul1"
' ---------------------------------------------------------------------------
' VBA-Modul zur Arbeitsmappe Produkt_Marktplatz_Kalkulator.xlsx
'
' Ein Makro, das einen wiederkehrenden Handgriff abnimmt - keine Vorfuehrung.
' BerichtErzeugen aktualisiert die Berechnung, sortiert die Kalkulation nach
' Deckungsbeitrag und legt einen datierten Kurzbericht als eigenes Blatt an.
' Genau das war im Alltag der Schritt, den man dreimal pro Woche von Hand
' gemacht hat.
'
' EINBINDEN
'   1. Excel oeffnen, Alt+F11 (VBA-Editor).
'   2. Datei > Datei importieren, diese .bas-Datei waehlen.
'   3. Mappe als .xlsm speichern (Excel-Arbeitsmappe mit Makros).
'   4. Makro ueber Alt+F8 > BerichtErzeugen starten.
'
' Warum liegt das hier und nicht in der Mappe: Die Mappe wird von einem
' Python-Skript erzeugt. VBA liegt in einem binaeren Projektcontainer
' (vbaProject.bin), den keine offene Bibliothek schreiben kann. Statt ein
' Makro zu behaupten, liegt der Code hier vollstaendig und importierbar.
' ---------------------------------------------------------------------------
Option Explicit

Private Const BLATT_KALK As String = "05_KALKULATION"
Private Const BLATT_CHECK As String = "08_CHECKS"
Private Const ERSTE_ZEILE As Long = 4

Public Sub BerichtErzeugen()
    Dim wsK As Worksheet, wsC As Worksheet, wsB As Worksheet
    Dim letzte As Long, i As Long
    Dim name As String
    Dim erloes As Double, db As Double
    Dim verlust As Long, offen As Long

    On Error GoTo Fehler
    Application.ScreenUpdating = False

    Set wsK = ThisWorkbook.Worksheets(BLATT_KALK)
    Set wsC = ThisWorkbook.Worksheets(BLATT_CHECK)

    ' 1  Alles neu rechnen. Erst danach wird gelesen - sonst steht im Bericht
    '    der Stand von vorgestern.
    ThisWorkbook.RefreshAll
    Application.CalculateFullRebuild

    letzte = wsK.Cells(wsK.Rows.Count, 1).End(xlUp).Row
    If letzte < ERSTE_ZEILE Then
        MsgBox "In " & BLATT_KALK & " stehen keine Daten.", vbExclamation
        GoTo Aufraeumen
    End If

    ' 2  Nach Deckungsbeitrag absteigend sortieren (Spalte P).
    With wsK.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsK.Range("P" & ERSTE_ZEILE & ":P" & letzte), _
                        SortOn:=xlSortOnValues, Order:=xlDescending
        .SetRange wsK.Range("A" & ERSTE_ZEILE & ":T" & letzte)
        .Header = xlNo
        .Apply
    End With

    ' 3  Kennzahlen einsammeln.
    For i = ERSTE_ZEILE To letzte
        If IsNumeric(wsK.Cells(i, 10).Value) And wsK.Cells(i, 10).Value <> "" Then
            erloes = erloes + wsK.Cells(i, 10).Value
        End If
        If IsNumeric(wsK.Cells(i, 16).Value) And wsK.Cells(i, 16).Value <> "" Then
            db = db + wsK.Cells(i, 16).Value
        End If
        If wsK.Cells(i, 20).Value = "Verlust" Then verlust = verlust + 1
        If wsK.Cells(i, 20).Value = "keine Berechnung" Then offen = offen + 1
    Next i

    ' 4  Berichtsblatt anlegen. Ein bestehendes Blatt gleichen Namens wird
    '    ersetzt - ein Bericht pro Tag genuegt.
    name = "Bericht_" & Format$(Date, "yyyy-mm-dd")
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets(name).Delete
    On Error GoTo Fehler
    Application.DisplayAlerts = True

    Set wsB = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    wsB.name = name

    With wsB
        .Range("A1").Value = "Kurzbericht Produkt- und Marktplatz-Kalkulator"
        .Range("A1").Font.Size = 14
        .Range("A1").Font.Bold = True
        .Range("A2").Value = "Erzeugt am " & Format$(Now, "dd.mm.yyyy, hh:nn") & " Uhr"
        .Range("A2").Font.Color = RGB(107, 107, 107)

        .Range("A4").Value = "Artikel in der Kalkulation"
        .Range("B4").Value = letzte - ERSTE_ZEILE + 1
        .Range("A5").Value = "davon ohne Berechnung"
        .Range("B5").Value = offen
        .Range("A6").Value = "Netto-Erloes gesamt"
        .Range("B6").Value = erloes
        .Range("A7").Value = "Deckungsbeitrag gesamt"
        .Range("B7").Value = db
        .Range("A8").Value = "Marge gesamt"
        If erloes <> 0 Then .Range("B8").Value = db / erloes
        .Range("A9").Value = "Artikel mit Verlust"
        .Range("B9").Value = verlust

        .Range("B6:B7").NumberFormat = "#,##0.00 ""€"""
        .Range("B8").NumberFormat = "0.0%"
        .Range("A4:A9").Font.Bold = True
        .Range("A11").Value = "Offene Pruefungen aus " & BLATT_CHECK & ":"
        .Range("A11").Font.Bold = True
    End With

    ' 5  Die Pruefungen mit Treffern uebernehmen. Was in Ordnung ist, muss
    '    nicht im Bericht stehen.
    Dim z As Long, ziel As Long
    ziel = 12
    For z = ERSTE_ZEILE To ERSTE_ZEILE + 20
        If Len(Trim$(CStr(wsC.Cells(z, 1).Value))) = 0 Then Exit For
        If wsC.Cells(z, 2).Value > 0 Then
            wsB.Cells(ziel, 1).Value = wsC.Cells(z, 1).Value
            wsB.Cells(ziel, 2).Value = wsC.Cells(z, 2).Value
            ziel = ziel + 1
        End If
    Next z
    If ziel = 12 Then wsB.Range("A12").Value = "keine"

    wsB.Columns("A:B").AutoFit
    wsB.Activate

Aufraeumen:
    Application.ScreenUpdating = True
    Exit Sub

Fehler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Abgebrochen: " & Err.Description, vbCritical, "BerichtErzeugen"
End Sub