Hallo Geistesblitz,
per VBA kann man die Zeit und Datumsangaben aus dem Text isolieren.
Der von mir erstellte Code ist mit ca. 150 Zeilen aber schon relativ lang. Probleme gibt es mit Werten wie 9.10 oder 20.01. Solche Werte können nicht eindeutig von Excel als Zeit/oder Datum erkannt werden. Standardmäßig konvertiert Excel solche Angaben in einen Datumswert.
Ein bischen Spielraum für Verfeinerungen oder Berücksichtigung anderer Vorgaben gibt es sicher noch.
Gruß
Franz
Sub Extract\_Zeit\_Datum()
Dim wks As Worksheet, vS
Dim sF As String, sR As String, sText As String, sTemp As String
Dim Zeile As Long, Spalte As Long, Zeile\_L As Long, iJ As Long
Set wks = ActiveSheet
With wks
'letzte Zeile mit Daten in Spalte A(1)
Zeile\_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Formate und Inhalte löschen in Spalten rechts von Spalte A
Spalte = .Cells.SpecialCells(xlCellTypeLastCell).Column
If Spalte \> 1 Then
With .Range(.Columns(2), .Columns(Spalte))
.ClearContents
.ClearFormats
End With
End If
End With
Application.ScreenUpdating = False
'Einlesen und Aufbereiten der Daten aus Spalte A
For Zeile = 1 To Zeile\_L
Application.StatusBar = "Zeile " & Format(Zeile, "00000") & " von " \_
& Format(Zeile\_L, "00000") & " wird bearbeitet."
sText = wks.Cells(Zeile, 1).Text
'Uhr, Avis und Abhol durch Sonderzeichen ersetzen
sF = " Uhr": sR = " §§§": sText = VBA.Replace(sText, sF, sR)
sF = " uhr": sText = VBA.Replace(sText, sF, sR)
sF = "uhr": sText = VBA.Replace(sText, sF, sR)
sF = "Uhr": sText = VBA.Replace(sText, sF, sR)
sF = "Abhol": sR = "}}}}}": sText = VBA.Replace(sText, sF, sR)
sF = "Avis ": sR = "{{{{ ": sText = VBA.Replace(sText, sF, sR)
sF = "Avis": sText = VBA.Replace(sText, sF, sR)
sF = "avis ": sText = VBA.Replace(sText, sF, sR)
sF = "avis": sText = VBA.Replace(sText, sF, sR)
sTemp = ""
'Alle Zeichen im Text außer Ziffern, Trennzeichen für Datum/Zeit und den \_
obigen Sonderzeichen durch Leerzeichen ersetzen
For iJ = 1 To Len(sText)
Select Case Asc(Mid(sText, iJ, 1))
Case 32, 45, 46, 48 To 57, 58, 123, 125, 167 '" ","-", ".", 0 bis 9, \_
":","{","}","§"
'Zeichen nicht ersetzen
sTemp = sTemp & Mid(sText, iJ, 1)
Case Else
'Zeichen durch Blank erstzen
sTemp = sTemp & " "
End Select
Next
sText = sTemp
'obige Sonderzeichen-Blöcke wieder durch Uhr, Avis und Abholung ersetzen
sF = "§§§": sR = " Uhr ": sText = VBA.Replace(sText, sF, sR)
sF = "{{{{": sR = " Avis ": sText = VBA.Replace(sText, sF, sR)
sF = "}}}}}": sR = " Abholung ": sText = VBA.Replace(sText, sF, sR)
'Einzelne Sonderzeichen durch Leerzeichen ersetzen
sR = " "
sF = "§": sText = VBA.Replace(sText, sF, sR)
sF = "{": sText = VBA.Replace(sText, sF, sR)
sF = "}": sText = VBA.Replace(sText, sF, sR)
'Datums/Zeittrennzeichen zwischen Leerzeichen durch Leerzeichen ersetzen
sR = " ":
sF = " . ": sText = VBA.Replace(sText, sF, sR)
sF = " - ": sText = VBA.Replace(sText, sF, sR)
sF = " : ": sText = VBA.Replace(sText, sF, sR)
'Mehrfach-Punke durch Leerzeichen ersetzen
sR = " "
Do Until InStr(1, sText, "...") = 0
sF = "...": sText = VBA.Replace(sText, sF, sR)
Loop
Do Until InStr(1, sText, "..") = 0
sF = "..": sText = VBA.Replace(sText, sF, sR)
Loop
Do Until InStr(1, sText, " .") = 0
sF = " .": sText = VBA.Replace(sText, sF, sR)
Loop
'"--" im Text durch Leerstring ersetzen
sR = ""
Do Until InStr(1, sText, "--") = 0
sF = "--": sText = VBA.Replace(sText, sF, sR)
Loop
If Trim(sText) = "-" Then sText = ""
'Doppel-Leerzeichen durch Einfach-Leerzeichen ersetzen
sR = " "
Do Until InStr(1, sText, " ") = 0
sF = " ": sText = VBA.Replace(sText, sF, sR)
Loop
sText = Trim(sText)
'Text am Leerzeichen splitten
vS = Split(sText, " ")
'Text vor Uhr auf Zeitschreibweise mit "." prüfen und ggf. durch ":" ersetzen
For iJ = UBound(vS) To LBound(vS) + 1 Step -1
If vS(iJ) = "Uhr" Then
If Len(vS(iJ - 1)) - Len(Replace(vS(iJ - 1), ".", "")) = 1 Then
sF = ".": sR = ":": vS(iJ - 1) = VBA.Replace(vS(iJ - 1), sF, sR)
End If
End If
Next
'Text nach "Avis" auf Zeitschreibweise mit "." prüfen und ggf. durch ":" ersetzen
For iJ = LBound(vS) To UBound(vS) - 1
If vS(iJ) = "Avis" Then
If Len(vS(iJ + 1)) - Len(Replace(vS(iJ + 1), ".", "")) = 1 Then
sF = ".": sR = ":": vS(iJ + 1) = VBA.Replace(vS(iJ + 1), sF, sR)
End If
End If
Next
sTemp = ""
'Textteile in den Arrayfeldern auf Datum/Zeit und Besonderheiten prüfen
For iJ = LBound(vS) To UBound(vS)
'Prüfen ob Datum/Zeit
If IsDate(vS(iJ)) Then
If Len(vS(iJ)) \> 5 Then '---\> Datumsangabe
vS(iJ) = Format(CDate(vS(iJ)), "YYYY-MM-DD")
Else
If InStr(1, vS(iJ), ".") \> 1 Then '---\>Datum oder Zeit ist nicht eindeutig
If Val(Left(vS(iJ), InStr(1, vS(iJ), ".") - 1)) 12 And \_
Val(Mid(vS(iJ), InStr(1, vS(iJ), ".") + 1)) 12 UND Wert muss Uhrzeit \_
sein, kann kein Datum sein
sF = ".": sR = ":": vS(iJ) = VBA.Replace(vS(iJ), sF, sR)
vS(iJ) = Format(CDate(vS(iJ)), "hh:mm")
Else
'Angabe wie z.B. 20.1 in ein Datum des aktuellen Jahres umwandeln.
vS(iJ) = Format(CDate(vS(iJ)), "YYYY-MM-DD")
End If
Else
'Zeitangabe in einheitliche Schreibweise umwandeln.
vS(iJ) = Format(CDate(vS(iJ)), "hh:mm")
End If
End If
ElseIf InStr(2, vS(iJ), ".") \> 1 Then
'Nicht-Datums-Text enthält Punkt(e), diese durch ":" ersetzen
sF = ".": sR = ":": vS(iJ) = VBA.Replace(vS(iJ), sF, sR)
'neuen Inhalt auf Datums-Eigenschaft prüfen
If IsDate(vS(iJ)) Then
'Zeitangabe in einheitliche Schreibweise umwandeln.
vS(iJ) = Format(CDate(vS(iJ)), "hh:mm")
ElseIf InStr(1, vS(iJ), "-") \> 1 Then
'in einer von bis Zeitangabe 09:30-10:00 den "-" durch Leerzeichen ersetzen
sF = "-": sR = " ": vS(iJ) = VBA.Replace(vS(iJ), sF, sR)
End If
ElseIf InStr(1, vS(iJ), "-") \> 1 Then
'in einer von bis Zeitangabe 09:30-10:00 den "-" durch Leerzeichen ersetzen
sF = "-": sR = " ": vS(iJ) = VBA.Replace(vS(iJ), sF, sR)
ElseIf IsNumeric(vS(iJ)) Then
'Zahlenwerte durch einen Leerstring ersetzen
vS(iJ) = ""
End If
'Text-String neu zusammensetzen
If sTemp = "" Then sTemp = vS(iJ) Else sTemp = sTemp & " " & vS(iJ)
Next
sText = sTemp
'Text "Uhr" durch Leerstring ersetzen und Doppelte Leerzeichen entfernen
sF = " Uhr": sR = "": sText = VBA.Replace(sText, sF, sR)
sF = " ": sR = " ": sText = VBA.Replace(sText, sF, sR)
sText = Trim(sText)
'aufbereiteten Text in Tabelle schreiben
Spalte = 2
wks.Cells(Zeile, Spalte) = "'" & sText
'Zeit/Datumsangaben in separate Spalten eintragen
vS = Split(sText, " ")
For iJ = LBound(vS) To UBound(vS)
If IsDate(vS(iJ)) Then
Spalte = Spalte + 1
With wks.Cells(Zeile, Spalte)
.Value = vS(iJ)
If .Value
)