Hallo,

ich hab' Dir mal was geproggt, kann man an einigen Stellen noch beschleunigen, aber sollte vielleicht erstmal reichen.

Deine Mappe scheint beim Abspeichern und Öffnen sehr träge zu sein, da solltest Du nochmal nachchecken....

Option Explicit

Public Sub test()
Const START_ROW As Long = 6
Const READCOLUMN_DATE As Long = 36
Const PRINTCOLUMN_DATE As Long = 38
Const READCOLUMN_VALUE As Long = 35
Const PRINTCOLUMN_VALUE As Long = 37
Dim avntArray As Variant
Dim avntValues() As Variant
Dim avntPrint(1 To 2) As Variant
Dim lngColumn As Long, lngCount As Long
Dim ialngRow As Long, ialngColumn As Long
Dim objCell As Range
Dim aobjRange(1 To 2) As Range
Application.ScreenUpdating = False
With ActiveSheet
    If .Cells(.Rows.Count, PRINTCOLUMN_DATE).End(xlUp).Row >= .Cells(.Rows.Count, PRINTCOLUMN_VALUE).End(xlUp).Row Then
      lngColumn = PRINTCOLUMN_DATE
    Else
      lngColumn = PRINTCOLUMN_VALUE
    End If
    .Cells(START_ROW, PRINTCOLUMN_VALUE).Resize(.Cells(.Rows.Count, lngColumn).End(xlUp).Row, 2).ClearContents
    If .Cells(.Rows.Count, READCOLUMN_DATE).End(xlUp).Row >= .Cells(.Rows.Count, READCOLUMN_VALUE).End(xlUp).Row Then
      lngColumn = READCOLUMN_DATE
    Else
      lngColumn = READCOLUMN_VALUE
    End If
    avntArray = .Cells(START_ROW, READCOLUMN_VALUE).Resize(.Cells(.Rows.Count, lngColumn).End(xlUp).Row, 2)
    For ialngColumn = 1 To UBound(avntArray, 2)
       lngCount = 0
       For ialngRow = 1 To UBound(avntArray, 1)
          If avntArray(ialngRow, ialngColumn) <> vbNullString Then
            lngCount = lngCount + 1
            If ialngColumn = 1 Then _
              ReDim Preserve avntValues(1, lngCount - 1) As Variant
            avntValues(ialngColumn - 1, lngCount - 1) = avntArray(ialngRow, ialngColumn)
          End If
       Next
    Next
    .Cells(START_ROW, PRINTCOLUMN_VALUE).Resize(UBound(avntValues, 2) + 1, 2) = WorksheetFunction.Transpose(avntValues)
    Set aobjRange(1) = .Cells(START_ROW, PRINTCOLUMN_VALUE).Resize(UBound(avntValues, 2) + 1, 1)
    Set aobjRange(2) = .Cells(START_ROW, PRINTCOLUMN_DATE).Resize(UBound(avntValues, 2) + 1, 1)
    avntPrint(1) = aobjRange(1)
    avntPrint(2) = aobjRange(2)
    aobjRange(1) = avntPrint(2)
    aobjRange(2) = avntPrint(1)
    aobjRange(1).NumberFormat = "m/d/yyyy"
    aobjRange(2).NumberFormat = "General"
    For Each objCell In aobjRange(1)
       If objCell = vbNullString Then Exit For
       objCell = DateValue(CStr(objCell))
    Next
 End With
 Erase aobjRange
 Application.ScreenUpdating = True
End Sub

Gruß,