If Dir(ImaPapki, 16) = "" Then MkDir ImaPapki 
FiIma = Dir(Put1 & Maska, 16) 

Public Sub MoveFilesExceptActiveSheet91()
    Dim destinationFolder As String
    Dim activeSheetName As String
    Dim file As String
    Dim sourceFolder As String
    sourceFolder = ActiveWorkbook.Path & "\"
    
    ' отримуємо шлях до папки з активним аркушем
    sourceFolder = ThisWorkbook.Path & "\"
    
    ' отримуємо назву активного аркуша
    activeSheetName = ActiveSheet.Name
    
    ' створюємо папку з ім'ям, яке зберігається в комірці A1
    destinationFolder = sourceFolder & Range("A1").Value & "\"
    If Dir(destinationFolder, vbDirectory) = "" Then
        MkDir destinationFolder
    End If
    
    ' перебираємо всі файли в першій папці
    file = Dir(sourceFolder & "*", vbDirectory)
    Do While (file <> "")
        ' перевіряємо, чи файл є активним аркушем Excel
        If Not (file Like activeSheetName & ".*") Then
            ' перевіряємо, чи файл має потрібне розширення
            If (file Like "*.xlsx") Or (file Like "*.xls") Or (file Like "*.rar") Or (file Like "*.jpg") Or (file Like "*.png") Or (file Like "*.dwg") Or (file Like "*.pdf") Or (file Like "*.txt") Or (file Like "*.bak") Then
                ' переміщуємо файл в нову папку
                Name sourceFolder & file As destinationFolder & file
            End If
        End If
        
        ' переходимо до наступного файлу
        file = Dir()
    Loop
    
    ' перебираємо всі папки в першій папці
    file = Dir(sourceFolder & "*", vbDirectory)
    Do While (file <> "")
        ' перевіряємо, чи файл є активним аркушем Excel
        If Not (file Like activeSheetName & ".*") Then
            ' перевіряємо, чи файл є папкою
            If (GetAttr(sourceFolder & file) And vbDirectory) = vbDirectory Then
                ' перевіряємо, чи папка не є джерелом або призначенням
                If (file <> ".") And (file <> "..") Then
                    ' переміщуємо папку в нову папку
                    Name sourceFolder & file As destinationFolder & file
                End If
            End If
        End If
        
        ' переходимо до наступного файлу
        file = Dir()
    Loop
End Sub

Public Sub MoveFilesExceptActiveSheet9()
    
    Dim destinationFolder As String
    Dim activeSheetName As String
    Dim file As String
    Dim sourceFolder As String
    sourceFolder = ActiveWorkbook.Path & "\"
    
    ' получаем путь к папке с активным листом
    sourceFolder = ThisWorkbook.Path & "\"
    
    ' получаем названия активного листа
    activeSheetName = ActiveSheet.Name
    
    ' создаем папку с именем, хранящимся в ячейке A1
    destinationFolder = sourceFolder & Range("A1").Value & "\"
    If Dir(destinationFolder, vbDirectory) = "" Then
        MkDir destinationFolder
    End If
    
    ' Перебираем все файлы в первой папке
    file = Dir(sourceFolder & "*")
    Do While (file <> "")
        ' проверяем файл активним листом Excel
        If Not (file Like activeSheetName & ".*") Then
            ' Перевіряємо, чи файл має потрібне розширення
            If (file Like "*.xlsx") Or (file Like "*.xls") Or (file Like "*.rar") Or (file Like "*.jpg") Or (file Like "*.png") Then
                ' Переміщуємо файл в нову папку
                Name sourceFolder & file As destinationFolder & file
            End If
        End If
        
        ' Переходимо до наступного файлу
        file = Dir()
    Loop
End Sub