Option Explicit
Const SearchPath As String = "%%thisworkbook%%\Berichte\"
Sub FindNewFiles()
Dim wsh As Worksheet
Dim sPath As String
Dim sFile As String
Dim colFiles As New Collection
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
sPath = GetPath(SearchPath)
sFile = Dir(sPath & "*.xlsm")
Set wsh = ThisWorkbook.Worksheets(2)
Do Until sFile = ""
sFile = Left(sFile, Len(sFile) - 1 - Len(fso.GetExtensionName(sPath & sFile)))
If wsh.Range("A:A").Find(what:=sFile, lookAt:=xlWhole) Is Nothing Then
colFiles.Add sFile
End If
sFile = Dir()
Loop
SortCollection colFiles
ViewCollection colFiles, ThisWorkbook.Worksheets(2).Range("B:B")
End Sub
Sub ViewCollection(colF As Collection, rngOut As Range)
Dim rng As Range
Dim iPos As Integer
rngOut.ClearContents
iPos = 1
For Each rng In rngOut.Cells
If iPos <= colF.Count Then
rng.Value = colF.Item(iPos)
iPos = iPos + 1
Else
Exit For
End If
Next
End Sub
Sub SortCollection(ByRef colF As Collection)
Dim iPos As Integer
iPos = 2
Do Until iPos > colF.Count
If colF.Item(iPos - 1) > colF.Item(iPos) Then
colF.Add Item:=colF.Item(iPos - 1), After:=iPos
colF.Remove iPos - 1
If iPos > 2 Then
iPos = iPos - 1
End If
Else
iPos = iPos + 1
End If
Loop
End Sub
Function GetPath(ByVal sPath As String) As String
sPath = Replace(sPath, "%%thisworkbook%%", ThisWorkbook.Path)
GetPath = sPath
End Function