Absturz beim Speichern als xlsx

Sub Liste_sortieren()
Dim rng As Range, rngDel As Range, rngSuche As Range
Dim vTitel As Variant
Dim i&, j&
Dim lngCLC&, lngListExist&, lngOC&, lngAnzZeilen&, lngErste&, lngZweite&, lngNr&
Dim strDat$
On Error GoTo Fehler
' Überschriften die NICHT gelöscht werden sollen
vTitel = Array("nummer", "name", "datum", "betrag")
'Überschriften suchen und nicht benötigte löschen
For Each rng In ActiveSheet.UsedRange.Rows(1).Cells
If IsError(Application.Match(rng, vTitel, 0)) Then
If rngDel Is Nothing Then
Set rngDel = rng.EntireColumn
Else
Set rngDel = Union(rngDel, rng.EntireColumn)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rng = Nothing
Set rngDel = Nothing
'Schauen ob benutzerdefinierte Liste bereits existiert
lngListExist = Application.GetCustomListNum(vTitel)
'Falls ja, wird die Listennummer für die Sortierung um 1 erhöht, da bei der Sort-Methode  _
die 1 die Nummer für die Standardsortierung ist
'Falls nein, wird die benutzerdefinierte Liste kreiert und dann die Listennumer erhöht - _
siehe oben
If lngListExist > 0 Then
lngOC = lngListExist + 1
Else
Application.AddCustomList listArray:=vTitel
lngCLC = Application.CustomListCount
lngOC = lngCLC + 1
End If
'Die Spalten werden sortiert
i = Worksheets(1).UsedRange.Columns.Count
j = Worksheets(1).UsedRange.Rows.Count
Range(Cells(1, 1), Cells(j, i)).Sort Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=lngOC, _
MatchCase:=False, Orientation:=xlLeftToRight
'Benutzerdefinierte Liste wieder löschen, falls sie neu kreiert worden ist
If lngListExist = 0 Then Application.DeleteCustomList ListNum:=lngCLC
Set rng = Nothing
Set rngSuche = Nothing
Set rngDel = Nothing
' Speichern
strDat = Format(Now, "yymmdd")
ChDir "I:\"
ActiveWorkbook.SaveAs Filename:="Soll_" & strDat & ".xlsx", FileFormat:=xlOpenXMLWorkbook
MsgBox "Die Ausführung wurde erfolgreich beendet"
Exit Sub
Fehler:     MsgBox "Fehler, bitte an Administrator benachrichtigen"
End Sub