Циклическая проверка на существование папки и ее создание

Sub m_1()
Dim FileSystemObject As Scripting.FileSystemObject
Dim ОбщаяПапка As Scripting.Folder
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set ОбщаяПапка = FileSystemObject.GetFolder("C:\Documents and Settings\Пользователь\Рабочий стол\Папка")
ОбщаяПапка.SubFolders.Add ОбщаяПапка.SubFolders.Count + 1
End Sub

Sub CheckAndIncrement()
    Dim i As Long, BasePath As String
    Dim fs As Object
    
    BasePath = "D:\Документы\"
    
    i = 1
    Do While DirExist(BasePath, Trim(CStr(i)))
        i = i + 1
    Loop
    Set fs = CreateObject("Scripting.FileSystemObject")
    Call fs.CreateFolder(BasePath & Trim(CStr(i)))
    Set fs = Nothing
End Sub
 
Private Function DirExist(MyPath As String, DirToFind As String) As Boolean
    Dim MyName As String
    
    DirExist = False
    MyName = Dir(MyPath, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
            If MyName = DirToFind Then
                DirExist = True
                'Debug.Print MyPath & MyName
                Exit Do
            End If
            End If
        End If
        MyName = Dir
    Loop
End Function

Sub CheckAndIncrement()
    Dim i As Long, BasePath As String
    
    BasePath = "D:\Документы\"
    
    i = 1
    Do While CreateObject("Scripting.FileSystemObject").FolderExists(BasePath & Trim(CStr(i)))
        i = i + 1
    Loop
    Call CreateObject("Scripting.FileSystemObject").CreateFolder(BasePath & Trim(CStr(i)))
End Sub