VBA-Makro

Function FindDateInString(strString$) As Date
Dim objMatch As Object, oDate As Date
If Regex Is Nothing Then
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.MultiLine = True
.Pattern = "\d+[-]\d+[-]\d+"
.Global = True
End With
End If
Set objMatch = Regex.Execute(strString$)
If objMatch.Count > 0 Then
oDate = DateValue(objMatch(0))
End If
FindDateInString = oDate
End Function

Sub Copy_Transpose_Range()
Dim rngTitel As Range, rngDaten As Range, rngTmp As Range
Dim lngAbstand As Long
Dim meARDate(), nCount
With Sheets("Daten")
Set rngTitel = .Range("A4:A6")
Set rngTmp = .Columns(1).Find(What:="Heure", LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not rngTmp Is Nothing Then
Set rngDaten = rngTmp.Offset(0, 1).Resize(3, 24)
nCount = nCount + 1
ReDim Preserve meARDate(1 To nCount)
meARDate(nCount) = FindDateInString(rngTmp.Offset(-2, 0).Text)
Set rngTmp = .Columns(1).FindNext(rngTmp)
Do While rngTmp.Address  rngTitel(1).Address
nCount = nCount + 1
ReDim Preserve meARDate(1 To nCount)
meARDate(nCount) = FindDateInString(rngTmp.Offset(-2, 0).Text)
Set rngDaten = Union(rngDaten, rngTmp.Offset(0, 1).Resize(3, 24))
Set rngTmp = .Columns(1).FindNext(rngTmp)
Loop
End If
End With
nCount = 1
If Not rngDaten Is Nothing Then
With Sheets.Add(After:=Sheets(Sheets.Count))
.Range("A1") = "Datum"
.Range("B1:D1") = Application.Transpose(rngTitel)
.Rows(1).Font.Bold = True
For Each rngTmp In rngDaten.Areas
With .Range("A2").Offset(lngAbstand, 0)
.Offset(0, 1).Resize(24, 3).Value = Application.Transpose(rngTmp)
.Resize(24, 1) = meARDate(nCount)
.Resize(24, 1).NumberFormat = "m/d/yyyy"
End With
nCount = nCount + 1
lngAbstand = lngAbstand + rngTmp.Columns.Count
Next rngTmp
.UsedRange.EntireColumn.AutoFit
End With
End If
Set Regex = Nothing
End Sub