Sub Путь_к_папке3()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку"
        If .Show = False Then Exit Sub
        sfolder = .SelectedItems(1)
    End With
    [B5] = sfolder
End Sub
Sub Путь_к_папке2()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку"
        If .Show = False Then Exit Sub
        sfolder = .SelectedItems(1)
    End With
    [B7] = sfolder
End Sub
Sub Перенос()
    sfolder = [B5]
    sfolder = sfolder & IIf(Right(sfolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    sfiles = Dir(sfolder & "*.*")
    sfolder2 = [B7]
    sfolder2 = sfolder2 & IIf(Right(sfolder2, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Set slov = CreateObject("scripting.dictionary")
    Do While sfiles <> ""
        nm = Replace(sfiles, ".jpg", "")
        slov(nm) = sfolder & sfiles
        sfiles = Dir
    Loop
    Dim fso, f
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each vk In slov.keys
        Application.StatusBar = vk
        If Dir(sfolder2 & vk, vbDirectory) = "" Then
            MkDir sfolder2 & vk
            MkDir sfolder2 & vk & "\foto"
            MkDir sfolder2 & vk & "\video"
            MkDir sfolder2 & vk & "\text"
        End If
        Set f = fso.GetFile(slov(vk))
        dnm = sfolder2 & vk & "\foto\" & vk & ".jpg"
        If Dir(dnm) <> "" Then Kill dnm
        f.Move dnm
    Next
End Sub