Private Sub VerzeichnisseAuflisten()
 
Dim Basisordner As String
Dim NeuerOrdner As String
Dim arr() As String
Dim i As Integer
Dim Ergebnis As Integer
Dim NameNeu As String
 
ReDim Preserve arr(0)
 
Basisordner = "d:\test"
 
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
 
Dim fld As Object
Set fld = fso.getfolder(Basisordner)
 
Dim sfld As Object
 
For Each sfld In fld.subfolders
i = i + 1
ReDim Preserve arr(i)
arr(i - 1) = CInt(sfld.Name)
Next
 
For i = 0 To UBound(arr()) - 1
If arr(i) > Ergebnis Then
Ergebnis = arr(i)
End If
Next
 
NameNeu = Format(Ergebnis + 1, "0000")
 
NeuerOrdner = Basisordner & "\" & NameNeu
 
MkDir (NeuerOrdner)
 
ThisWorkbook.SaveAs (NeuerOrdner & "\" & NameNeu & ".xlsx")
 
End Sub

EALA FREYA FRESENA