AW: VBA - konvert. Datum nicht filterbar
13.03.2020 10:41:29
UweD
Hallo
ich hab noch ein paar Prüfungen eingebaut.
Sub Konvertierung()
ActiveWorkbook.Unprotect Password:=""
ActiveSheet.Unprotect Password:=""
Set ZRB = ThisWorkbook.Sheets(1)
Dim i, y As Integer
Dim R As Range
Dim Today As Date
Today = Date
Set R = Range(ZRB.Cells(1, 10), ZRB.Cells(200, 10))
y = Application.WorksheetFunction.CountA(R)
For i = 2 To y
If ZRB.Cells(i, 14) = "" Then
'Prüfung 1
If Not (ZRB.Cells(i, 8) = "" And ZRB.Cells(i, 11) = "") Then
If Len(ZRB.Cells(i, 8)) - Len(Replace(ZRB.Cells(i, 8), ".", "")) = 2 Then
ZRB.Cells(i, 14) = DateValue(ZRB.Cells(i, 8))
ElseIf IsNumeric(ZRB.Cells(i, 8)) Then
If CDbl(ZRB.Cells(i, 8)) >= 40179 And CDbl(ZRB.Cells(i, 8)) < Today Then
ZRB.Cells(i, 14) = CDbl(ZRB.Cells(i, 8))
End If
End If
'Prüfung 2
If Left(ZRB.Cells(i, 8), 2) >= 1 And Left(ZRB.Cells(i, 8), 2) <= 12 Then
If Mid(ZRB.Cells(i, 8), 3, 1) = "B" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2018") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "C" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2019") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "D" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2020") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "E" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2021") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "F" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2022") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "G" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2023") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "H" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2024") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "K" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2008") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "L" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2009") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "M" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2010") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "N" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2011") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "P" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2012") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "Q" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2013") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "R" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2014") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "S" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2014") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "T" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2016") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "U" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2017") * 1
If Mid(ZRB.Cells(i, 8), 3, 1) = "V" Then ZRB.Cells(i, 14) = DateValue("01." & Left(ZRB.Cells(i, 8), 2) & "." & "2018") * 1
End If
'Prüfung 3
If ZRB.Cells(i, 14) = "" Then ZRB.Cells(i, 14) = ZRB.Cells(i, 11).Value
ZRB.Cells(i, 14).NumberFormat = "dd.mm.yyyy"
ZRB.Cells(i, 14).HorizontalAlignment = xlCenter
ZRB.Cells(i, 14).VerticalAlignment = xlCenter
End If
End If
Next
'ActiveSheet.Protect AllowFormattingCells:=True, Password:=""
'ActiveWorkbook.Protect Password:=""
Application.ScreenUpdating = True
End Sub
LG UweD