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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim D
Application.EnableEvents = False
On Error Resume Next
D = Split(Target.Value & "-99-99", "-")
If D(1) = 99 Then D(1) = 12
If D(2) = 99 Then D(2) = Day(DateSerial(D(0), D(1) + 1, 0))
Target.Value = Format(DateSerial(D(0), D(1), D(2)), "DD.MM.YYYY")
Application.EnableEvents = True
End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(5)) Is Nothing Then
Application.EnableEvents = False
For Each it In Target.Cells
If Len(Trim(it)) = 4 And IsNumeric(Trim(it)) Then it.Value = CDate("31-12-" & Trim(it))
If Trim(it) <> "" And Trim(it.Text) <> Format(it, "dd-mm-yyyy") Then it.Value = Application.EoMonth(it, 0)
it.NumberFormat = "DD.MM.YYYY"
Next
Application.EnableEvents = True
End If
End Subdim Eingabe as string
dim Datum as string
Eingabe = ".. dein Datumsstext..."
If Eingabe like "####" Then '--- nur die Jahreszahl
Datum = Cdate("31.12." & Eingabe)
Else If Eingabe like "[JFMASOND]* ####" Then '--- Monat und Jahreszahl am ende
Datum = Worksheetfunction.EoMonth(CDate(Eingabe), 0)
Elseif IsDate(Eingabe) then '--- ale anderen Texte, die wie ein Datum aussehen
Datum = Cdate(Eingabe)
Else
Datum = "Datum nicht ermittelbar
end if
Cells(x, y).FormulaLocal = Datum