AW: Im Anhang ist...
27.04.2026 12:16:09
Christian
Hallo Case,
erstmal vielen Dank für deine Mühe.
Was heißt hier Ansatz, das war eine funktionierende Lösung, die ich nur noch habe in meinen Code einbauen müssen. Dieser sieht jetzt so aus, funktioniert:
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
Gruß
Christian