Private Sub Worksheet_Change(ByVal Target As Range)

    On Error GoTo Cleanup



    Dim rngE As Range, rngH As Range, rngOP As Range

    Dim zelle As Range



    Set rngE = Intersect(Target, Me.Columns("E"))

    Set rngH = Intersect(Target, Me.Columns("H"))

    Set rngOP = Intersect(Target, Me.Columns("O:P"))



    If rngE Is Nothing And rngH Is Nothing And rngOP Is Nothing Then Exit Sub



    Application.EnableEvents = False

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual



    ' =========================

    ' SPALTE E (Forum-Logik)

    ' =========================

    If Not rngE Is Nothing Then

        For Each zelle In rngE

            Call FormatZelle_E(zelle)

        Next zelle

    End If



    ' =========================

    ' SPALTE H (nur Format + Ranking)

    ' =========================

    If Not rngH Is Nothing Then

        For Each zelle In rngH

            Call FormatZelle(zelle)

        Next zelle



        BerechneCodesRanking Me

    End If



    ' =========================

    ' AUTO FIT

    ' =========================

    If Not rngOP Is Nothing Then

        Me.Columns("A:Q").AutoFit

    End If



Cleanup:

    Application.EnableEvents = True

    Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True



    If Err.Number <> 0 Then

        MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbExclamation, "Worksheet_Change"

    End If

End Sub



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)



    Dim wsQ As Worksheet, wsZ As Worksheet

    Dim freieZeile As Long, zielZeile As Long

    Dim Antwort As VbMsgBoxResult

    Dim wertB As String

    Dim i As Integer



    Set wsQ = ThisWorkbook.Sheets("Codes")

    Set wsZ = ThisWorkbook.Sheets("NV")



    freieZeile = wsQ.Cells(wsQ.Rows.Count, "D").End(xlUp).Row + 1



    If Target.Row <> freieZeile Then Exit Sub



    Cancel = True



    wertB = UCase(Trim(wsQ.Cells(Target.Row, "B").Value))



    If wertB = "UNKNOWN" Or wertB = "UNKNOWNS" Then

        wsQ.Rows(Target.Row).Delete

        Exit Sub

    End If



    Antwort = MsgBox("Soll die Zeile verschoben werden?" & vbCrLf & _

                     "Ja = Verschieben nach NV" & vbCrLf & _

                     "Nein = Nur löschen", _

                     vbYesNoCancel + vbQuestion, "Aktion auswählen")



    If Antwort = vbCancel Then Exit Sub



    If Antwort = vbYes Then

        zielZeile = wsZ.Cells(wsZ.Rows.Count, "A").End(xlUp).Row + 1



        For i = 1 To 3

            With wsZ.Cells(zielZeile, i)

                .Value = wsQ.Cells(Target.Row, i).Value

                .Font.Color = wsQ.Cells(Target.Row, i).Font.Color

                .Font.Italic = True

                .HorizontalAlignment = xlCenter

            End With

        Next i



        With wsZ.Cells(zielZeile, 4)

            .Value = wsQ.Cells(Target.Row, "Q").Value

            .Font.Color = wsQ.Cells(Target.Row, "Q").Font.Color

            .Font.Italic = True

            .HorizontalAlignment = xlCenter

        End With



        wsZ.Columns("A:D").AutoFit

    End If



    wsQ.Rows(Target.Row).Delete



End Sub



Private Sub FormatZelle_E(ByVal zelle As Range)



    If Len(zelle.Value) = 0 Then

        Me.Cells(zelle.Row, "K").ClearContents

        Exit Sub

    End If



    If zelle.Hyperlinks.Count > 0 Then zelle.Hyperlinks.Delete



    Dim strTMP As String

    Dim datDate As Date



    strTMP = Trim(zelle.Text)



    ' -------------------------

    ' 1) Jahr ? 31.12.JJJJ

    ' -------------------------

    If strTMP Like "####" And IsNumeric(strTMP) Then

        zelle.Value = DateSerial(CLng(strTMP), 12 + 1, 0)



    ' -------------------------

    ' 2) Monat + Jahr ? Monatsende

    ' -------------------------

    ElseIf IsDate("1 " & strTMP) Then

        datDate = CDate("1 " & strTMP)

        zelle.Value = DateSerial(Year(datDate), Month(datDate) + 1, 0)



    ' -------------------------

    ' 3) vollständiges Datum ? ??? lassen

    ' -------------------------

    ElseIf IsDate(strTMP) Then

        zelle.Value = CDate(strTMP)

    End If



    zelle.NumberFormat = "dd.mm.yyyy"



    ' Styling

    With zelle

        .Font.Size = 11

        .Font.Name = "Calibri"

        .Font.Italic = True

        .Font.Bold = False

        .HorizontalAlignment = xlCenter

        .Font.Color = Me.Cells(.Row, "A").Font.Color

    End With



End Sub



Private Sub FormatZelle(ByVal zelle As Range)



    If Len(zelle.Value) = 0 Then Exit Sub



    If zelle.Hyperlinks.Count > 0 Then zelle.Hyperlinks.Delete



    If IsDate(zelle.Value) Then

        zelle.Value = CDate(zelle.Value)

        zelle.NumberFormat = "dd.mm.yyyy"

    End If



    With zelle

        .Font.Size = 11

        .Font.Name = "Calibri"

        .Font.Italic = True

        .Font.Bold = False

        .HorizontalAlignment = xlCenter

        .Font.Color = Me.Cells(.Row, "A").Font.Color

    End With



End Sub