' Bonus-Makro aus Teil 5 – Excel mit Copilot 2027
' Copilots korrigierte Fassung aus meinem zweiten Test (17.10.2026), unverändert.
' Dein Copilot schreibt für denselben Auftrag vermutlich anderen Code. Prüfe Deinen immer in einer Kopie.
' Einfügen: Alt + F11 -> Einfügen -> Modul -> Code einfügen. Vorher eine Kopie der Datei als .xlsm speichern!

Option Explicit

Sub RegionsblaetterErstellen()

    Dim wb As Workbook
    Dim quelle As Worksheet
    Dim tbl As ListObject
    Dim daten As Variant
    Dim blaetter As Object
    Dim naechsteZeile As Object

    Dim ziel As Worksheet
    Dim region As String
    Dim regionsSchluessel As Variant
    Dim basisName As String
    Dim blattName As String

    Dim regionSpalte As Long
    Dim umsatzSpalte As Long
    Dim zeile As Long
    Dim spalte As Long
    Dim zielZeile As Long
    Dim letzteDatenzeile As Long
    Dim summenzeile As Long

    On Error GoTo Fehler

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set wb = ThisWorkbook
    Set quelle = wb.Worksheets("Verkäufe")
    Set tbl = quelle.ListObjects("Verkaeufe")

    'Positionen der benötigten Tabellenspalten ermitteln.
    regionSpalte = tbl.ListColumns("Region").Index
    umsatzSpalte = tbl.ListColumns("Umsatz").Index

    'Prüfen, ob die Tabelle Datensätze enthält.
    If tbl.DataBodyRange Is Nothing Then
        MsgBox "Die Tabelle Verkaeufe enthält keine Daten.", _
               vbInformation
        GoTo Aufraeumen
    End If

    'Tabellendaten in den Arbeitsspeicher laden.
    daten = tbl.DataBodyRange.Value

    'Die beiden Dictionarys speichern:
    '1. das Zielblatt jeder Region
    '2. die nächste freie Zeile auf diesem Zielblatt
    Set blaetter = CreateObject("Scripting.Dictionary")
    Set naechsteZeile = CreateObject("Scripting.Dictionary")

    blaetter.CompareMode = vbTextCompare
    naechsteZeile.CompareMode = vbTextCompare

    For zeile = 1 To UBound(daten, 1)

        region = Trim$(CStr(daten(zeile, regionSpalte)))

        'Auch Datensätze ohne Regionsangabe erhalten ein Blatt.
        If region = "" Then region = "(Leer)"

        'Beim ersten Auftreten der Region ein neues Blatt anlegen.
        If Not blaetter.Exists(region) Then

            basisName = "Region - " & region
            blattName = EindeutigerBlattname(wb, basisName)

            Set ziel = wb.Worksheets.Add( _
                After:=wb.Worksheets(wb.Worksheets.Count))

            ziel.Name = blattName

            'Überschriften aus der Tabelle übernehmen.
            ziel.Range("A1").Resize( _
                1, tbl.ListColumns.Count).Value = _
                tbl.HeaderRowRange.Value

            'Überschriften formatieren.
            With ziel.Range("A1").Resize( _
                    1, tbl.ListColumns.Count)

                .Font.Bold = True
                .Interior.Color = RGB(31, 78, 121)
                .Font.Color = RGB(255, 255, 255)

            End With

            'Zahlenformate der einzelnen Quellspalten übernehmen.
            For spalte = 1 To tbl.ListColumns.Count

                ziel.Columns(spalte).NumberFormat = _
                    tbl.DataBodyRange.Columns(spalte).NumberFormat

            Next spalte

            blaetter.Add region, ziel
            naechsteZeile.Add region, 2

        End If

        Set ziel = blaetter(region)
        zielZeile = naechsteZeile(region)

        'Die vollständige Tabellenzeile in das Regionsblatt schreiben.
        ziel.Cells(zielZeile, 1).Resize( _
            1, UBound(daten, 2)).Value = _
            DatenzeileAlsArray(daten, zeile)

        naechsteZeile(region) = zielZeile + 1

    Next zeile

    'Umsatzsumme unter den Datensätzen jeder Region ergänzen.
    'Die For-Each-Variable ist vom Typ Variant.
    For Each regionsSchluessel In blaetter.Keys

        Set ziel = blaetter(regionsSchluessel)

        letzteDatenzeile = _
            naechsteZeile(regionsSchluessel) - 1

        summenzeile = letzteDatenzeile + 1

        ziel.Cells( _
            summenzeile, umsatzSpalte - 1).Value = _
            "Summe Umsatz"

        'R1C1 vermeidet Probleme mit lokalisierten Funktionsnamen.
        ziel.Cells( _
            summenzeile, umsatzSpalte).FormulaR1C1 = _
            "=SUM(R2C:R[-1]C)"

        With ziel.Range( _
                ziel.Cells(summenzeile, umsatzSpalte - 1), _
                ziel.Cells(summenzeile, umsatzSpalte))

            .Font.Bold = True

            With.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With

        End With

        ziel.Columns.AutoFit

    Next regionsSchluessel

    MsgBox blaetter.Count & _
           " Regionsblätter wurden erstellt.", _
           vbInformation

Aufraeumen:

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

Fehler:

    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MsgBox "Das Makro konnte nicht ausgeführt werden:" & _
           vbCrLf & Err.Description, _
           vbExclamation

End Sub


Private Function DatenzeileAlsArray( _
    ByRef daten As Variant, _
    ByVal zeile As Long) As Variant

    Dim ergebnis() As Variant
    Dim spalte As Long

    'Eine Tabellenzeile als zweidimensionales Array zurückgeben.
    ReDim ergebnis(1 To 1, 1 To UBound(daten, 2))

    For spalte = 1 To UBound(daten, 2)
        ergebnis(1, spalte) = daten(zeile, spalte)
    Next spalte

    DatenzeileAlsArray = ergebnis

End Function


Private Function EindeutigerBlattname( _
    ByVal wb As Workbook, _
    ByVal basisName As String) As String

    Dim bereinigterName As String
    Dim name As String
    Dim suffix As String
    Dim nummer As Long

    bereinigterName = BereinigeBlattname(basisName)

    If bereinigterName = "" Then
        bereinigterName = "Region"
    End If

    name = Left$(bereinigterName, 31)

    'Bei bereits vorhandenem Namen eine laufende Nummer ergänzen.
    If BlattExistiert(wb, name) Then

        nummer = 2

        Do
            suffix = " (" & nummer & ")"

            name = Left$( _
                bereinigterName, _
                31 - Len(suffix)) & suffix

            nummer = nummer + 1

        Loop While BlattExistiert(wb, name)

    End If

    EindeutigerBlattname = name

End Function


Private Function BereinigeBlattname( _
    ByVal name As String) As String

    Dim ungueltigesZeichen As Variant

    name = Trim$(name)

    'Diese Zeichen sind in Excel-Blattnamen nicht zulässig.
    For Each ungueltigesZeichen In _
        Array("\", "/", ":", "*", "?", "[", "]")

        name = Replace(name, ungueltigesZeichen, "_")

    Next ungueltigesZeichen

    BereinigeBlattname = name

End Function


Private Function BlattExistiert( _
    ByVal wb As Workbook, _
    ByVal blattName As String) As Boolean

    Dim ws As Worksheet

    On Error Resume Next
    Set ws = wb.Worksheets(blattName)
    On Error GoTo 0

    BlattExistiert = Not ws Is Nothing

End Function