Jüngstes Datum in Textstring ausgeben

Hallo zusammen,
nachdem meine Netzrecherchen nicht zum Ziel führten, anbei mein erster Beitrag in Form einer Frage...
Zum Hintergrund: Für meine Diplomarbeit hab ich ein Makro geschrieben, welches die Pressemitteilungen (ca. 3000) der Firmen einer Industrie aufbereitet. Hierbei bereinigt es diese um die Firmen-spezifischen Layoutelemente der heruntergeladenen HTML-Seiten und listet die bereinigten Pressetexte säuberlich in Excel auf.
Nun bräuchte ich eine Function, an die ich einen Datenstring übergeben kann (dieser enthält den bereinigten Pressemitteilungstext), welche mir dann das im Datenstring enthaltene jüngste Datum ausgibt. Die Anforderung des jüngsten Datums folgt aus der Besonderheit, dass zukunftsgerichtete Pressetexte häufig mehrere Daten enthalten, ich jedoch am Datum der Pressemitteilung (i.e., das jüngste Datum) interessiert bin. Die Ausgabe der Funktion sollte dann möglichst im Datentyp date erfolgen.
Da die Firmen aus den unterschiedlichsten Ländern stammen, wechseln die Notationen für das Datum zwischen den einzelnen Datenstrings. Denkbar sind v.a.:
Datetype1 = "##.##.####" 'dd.mm.yyyy oder mm.dd.yyyy
Datetype2 = "##.##.##" 'dd.mm.yy oder mm.dd.yy
Datetype3 = "##/##/####" 'dd/mm/yyyy oder mm/dd/yyyy
Datetype4 = "##/##/##" 'dd/mm/yy oder mm/dd/yy
Ausformulierte Monatsangaben werde ich manuell eintragen müssen.
Mein Lösungsansatz geht dahin, nach den wildcard-strings zu suchen, jedoch scheitere ich daran das jünste Datum im Textstring zu identifizieren und nur dieses auszugeben.
Besten Dank für jegliche Hilfe oder Anregung!
Mit vielen Grüssen,
Markus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub tst() Dim datD As Date, bolE As Boolean, zz As Long For zz = 1 To Cells(Rows.Count, 1).End(xlUp).Row MaxDatum Cells(zz, 1), datD, bolE If datD > 0 Then Cells(zz, 2) = datD Cells(zz, 3) = IIf(bolE, "ok", "unklar") Else Cells(zz, 2) = "kein Datum" End If Next zz End Sub Sub MaxDatum(ByVal strT As String, datM As Date, bolU As Boolean) Dim ii As Integer, datT As Date, datZ As Date datM = 0 For ii = 1 To Len(strT) - 7 If IsDate(Mid(strT, ii, 10)) Then datT = CDate(Mid(strT, ii, 10)) ElseIf IsDate(Mid(strT, ii, 8)) Then datT = CDate(Mid(strT, ii, 8)) End If If Day(datT) datM Or datZ > datM Then datM = Application.Max(datT, datZ) bolU = False End If Else datZ = 0 If datT > datM Then datM = datT bolU = True End If End If Next ii End Sub

Option Explicit Sub tst() Dim datD As Date, bolE As Boolean, zz As Long For zz = 1 To Cells(Rows.Count, 1).End(xlUp).Row MinDatum Cells(zz, 1), datD, bolE If datD > 0 Then Cells(zz, 2) = datD Cells(zz, 3) = IIf(bolE, "ok", "unklar") Else Cells(zz, 2) = "kein Datum" End If Next zz End Sub Sub MinDatum(ByVal strT As String, datM As Date, bolU As Boolean) Dim ii As Integer, datT As Date datM = CDate("31.12.9999") For ii = 1 To Len(strT) - 7 If IsDate(Mid(strT, ii, 10)) Then datT = CDate(Mid(strT, ii, 10)) ElseIf IsDate(Mid(strT, ii, 8)) Then datT = CDate(Mid(strT, ii, 8)) End If If datT > 0 Then If Day(datT) > 13 Then If datT 0 Then datT = Application.Min(datT, DateSerial(Year(datT), Day(datT), Month(datT))) If datT

Public Function DatumFinder(Txt As String, DatumFormat As Byte, DatumArt As Byte) As Date 'DatumFormat: 0 - DD.MM.YYYY ' 1 - MM/DD/YYYY 'DatumArt: 0 - kleinstes / Ältestes Datum ' 1 - grösstest / jüngtest Datum Dim TK As String Dim p1 As Long Dim Erg As Date Dim ZwErg As Date Dim Tag As Integer, Monat As Integer, Jahr As Integer Dim T1 As String, T2() As String Select Case DatumFormat Case 0 TK = "." Tag = 0 Monat = 1 Jahr = 2 Case 1 TK = "/" Tag = 1 Monat = 0 Jahr = 2 End Select Do p1 = InStr(p1 + 1, Txt, TK) If p1 = 0 Then Exit Do If Mid$(Txt, p1 + 3, 1) = TK Then T1 = Mid$(Txt, p1 - 2, 10) T2 = Split(T1, TK) If Not IsNumeric(T2(2)) Then T2(2) = Left(T2(2), 2) '--- Prüfung, ob Jahreszahl u.U 2- _ Stellig ZwErg = DateSerial(T2(Jahr), T2(Monat), T2(Tag)) If IsNumeric(T2(0)) Then If IsNumeric(T2(1)) Then If IsNumeric(T2(2)) Then Select Case DatumArt Case 0 If Erg = 0 Then Erg = ZwErg Else If ZwErg Erg Then Erg = ZwErg End If End Select End If End If End If p1 = p1 + 3 End If Loop DatumFinder = Erg End Function

Hi Markus,
hier noch eine Variante, bei der die TMJ- bzw. MTJ-Reihenfolge vorgegeben werden kann.
Wenn ein Datum aber nur in einer Reihenfolge sinnvoll sein, die der vorgegebenen widerspricht,
wird das Datum aus der sinnvollen Reihenfolge ausgegeben und die Änderung im letzten Parameter _ bekannt gegeben.


Option Explicit
Sub tst()
Dim datD As Date, bolE As Boolean, zz As Long, bolN As Boolean
For zz = 2 To Cells(Rows.Count, 1).End(xlUp).Row
bolN = False
MinDatum Cells(zz, 1), False, datD, bolN
If datD > 0 Then
Cells(zz, 2) = datD
If bolN Then Cells(zz, 2).Interior.ColorIndex = 3
Else
Cells(zz, 2) = "kein Datum"
End If
bolN = False
MinDatum Cells(zz, 1), True, datD, bolN
If datD > 0 Then
Cells(zz, 3) = datD
If bolN Then Cells(zz, 3).Interior.ColorIndex = 3
Else
Cells(zz, 3) = "kein Datum"
End If
Next zz
End Sub
Sub MinDatum(ByVal strT As String, ByVal bolAm As Boolean, datR As Date, bolF As Boolean)
Dim ii As Integer, intT As Integer, TT, datT As Date, bolZw As Boolean
datR = CDate("31.12.9999")
For ii = 1 To Len(strT) - 7
If Mid(strT, ii, 10) Like "##.##.####" Then
intT = 10
ElseIf Mid(strT, ii, 10) Like "##/##/####" Then
intT = 10
ElseIf Mid(strT, ii, 8) Like "##.##.##" Then
intT = 8
ElseIf Mid(strT, ii, 8) Like "##/##/##" Then
intT = 8
Else
intT = 0
End If
If intT > 0 Then
TT = Split(Mid(strT, ii, intT), Mid(strT, ii + 2, 1))
If TT(0) > 12 And bolAm Then bolZw = True:      bolAm = False
If TT(1) > 12 And Not bolAm Then bolZw = True:  bolAm = True
datT = DateSerial(TT(2), TT(1 + bolAm), TT(-bolAm))
If datT

Die Rückgaben, bei denen DE bzw. US falsch vorgegeben sind, werden rot eingefärbt.
Und hier die Mappe mit ein paar Beispielen: https://www.herber.de/bbs/user/54917.xls
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

	A	B	C
1	sdsf12.03.08df03.12.08dgd01.29.08dsfg	03.12.2008	unklar
2	sdsf12.03.08df03.12.08dgd12.29.08dsfg	29.12.2008	ok
3	sdsf12.03.08df13.12.08dgd01.08.08dsfg	13.12.2008	ok
4	sdsf12.03.08df31.12.2008dgd12.29.08dsfg	31.12.2008	ok
5	sdsf12.03.08df03.12.08dgd01.29.08dsfg06.05.09	05.06.2009	unklar
6	df30.12.08dgd01.29.08dsfg05.06.09	05.06.2009	unklar
7	df03.12.08dgd07.29.09dsfg05.06.09	29.07.2009	ok
8	arwer	kein Datum

Jüngstes Datum in Textstring ausgeben

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

317 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Jüngstes Datum in Textstring ausgeben

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

317 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread