Converts a csv containing students (user-)names to a pretty-printable-readable list. Result of an internship at my city.

schuelerliste.vb

' Alt + F11
' Doppelklick auf "Diese Arbeitsmappe"
' Dieses Skript Kopieren, und Einfügen
' Zurück zur Tabelle
' Alt + F8
' Doppelklick auf SchuelerlisteErstellen

Option Explicit

Sub SchuelerListeErstellen()
 
    ' Erstellt eine Schuelerliste
 
    ' Ermitteln wie viele Schueler die Schule hat
    Dim SchuelerIndex As Integer
    Dim SchuelerNummer As Integer

    For SchuelerIndex = 1 To 10000
    If Cells(SchuelerIndex, 1).Value = "" Then
            SchuelerNummer = SchuelerIndex
            Exit For
        End If
    Next
    SchuelerNummer = SchuelerNummer + 3

    ' Spalte für Nummerierung
    Columns(1).Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    ' Zeilenkopf einfügen
    Rows(1).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Nummer"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Nachname"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Vorname"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Benutzername"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Klasse"
 
    ' Zeilenkopf Fett machen und zentrieren
    Range("A1:E1").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Dim Zelle As Variant
    For Each Zelle In Range(Cells(1, 1), Cells(SchuelerNummer, 5))
        If Zelle.Value <> "" Then
            Zelle.Select
            ' Schriftgröße auf 14 setzen
            Selection.Font.Size = 14
            ' Rahmen um Zellen zeichnen
            If Zelle.Value <> "Nummer" And Zelle.Value <> "Nachname" And Zelle.Value <> "Vorname" And Zelle.Value <> "Klasse" And Zelle.Value <> "Benutzername" Then
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                ' Rahmen oben
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
            End If
        End If
    Next
    
    ' Für jede Klasse ein Arbeitsblatt erstellen
    Dim UnsortKlasse As Variant
    For Each UnsortKlasse In Range(Cells(2, 5), Cells(SchuelerNummer, 5))
        If UnsortKlasse <> "" Then
            If IsExistingWorksheet(UnsortKlasse) <> True Then
                Sheets(1).Select
                Sheets(1).Copy Before:=Sheets(1)
                Sheets(1).Name = UnsortKlasse
            End If
        End If
    Next
 
 
    Dim ws As Worksheet
    For Each ws In Worksheets
        Sheets(ws.Name).Select
        
        ' Klassen loeschen, die nicht in diesem Jahr sind - kompliziert, aber klappt ...
        Dim Geloescht As Boolean

        Do
            Geloescht = False
            Dim index As Integer
            For index = 2 To SchuelerNummer
                If Cells(index, 5).Value <> "" Then
                    If CStr(Cells(index, 5).Value) <> CStr(ws.Name) Then
                        Rows(index).Select
                        Selection.Delete Shift:=xlUp
                        Geloescht = True
                    End If
                End If
            Next
        Loop Until Geloescht = False
        
 
        ' Optimale Breite
        Cells.Select
        Selection.Columns.AutoFit

        ' Nach Nachnamen sortieren
        Columns("A:A").Select
        Range(Cells(1, 1), Cells(SchuelerNummer, 5)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _
            xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
    
        ' Schüler nummerieren
        Dim i As Integer
        For i = 2 To SchuelerNummer
            If Cells(i, 2).Value = "" Then
                Exit For
            Else
                Cells(i, 1).Select
                ActiveCell.FormulaR1C1 = CStr(i - 1)
                ' Zelle passend formatieren
                Selection.Font.Size = 14
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
            End If
        Next
    Next
    
    ' Arbeitsblaetter sortieren
    Dim lCount As Long, lCount2 As Long
    Dim lShtLast As Long

    lShtLast = Sheets.Count

    For lCount = 1 To lShtLast
        For lCount2 = lCount To lShtLast
            If UCase(Sheets(lCount2).Name) < UCase(Sheets(lCount).Name) Then
                Sheets(lCount2).Move Before:=Sheets(lCount)
            End If
        Next lCount2
    Next lCount
End Sub
 
Function IsExistingWorksheet(ByVal strSheetName As String) As Boolean
    Dim ws As Worksheet
    IsExistingWorksheet = False
    For Each ws In Worksheets
        If (StrComp(ws.Name, strSheetName, vbTextCompare) = 0) Then
            IsExistingWorksheet = True
            Exit For
        End If
    Next
End Function