Всё работает чудесно! Благодарю, задача решена!  

Список будет в виде наименований папок на листе Эксель, грубо говоря с ячейки А1 вниз до N строчки.

Написала код, но не перемещает, проверка наименования папки выдаёт ошибку "нет такой папки", хотя по выбранному диапазону она есть.

Sub Move_Folder()
   Dim xRg As Range, xCell As Range
   Dim sFolderName As FileDialog, sNewFolderName As FileDialog
   Dim xVal As String
   On Error Resume Next
   Dim objFSO As Object

   Set xRg = Application.InputBox("Выбрать диапазон наименований:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
   If xRg Is Nothing Then Exit Sub
   Set sFolderName = Application.FileDialog(msoFileDialogFolderPicker)
   sFolderName.Title = " Выбрать исходную папку:"
   If sFolderName.Show <> -1 Then Exit Sub
   Set sNewFolderName = Application.FileDialog(msoFileDialogFolderPicker)
   sNewFolderName.Title = " Выбрать папку, куда переносится:"
   If sNewFolderName.Show <> -1 Then Exit Sub
   
   For Each xCell In xRg
       xVal = xCell.Value
       If TypeName(xVal) = "String" And xVal <> "" Then
           FileCopy xSPathStr & xVal, xDPathStr & xVal
           Kill xSPathStr & xVal
       End If

Set objFSO = CreateObject("Scripting.FileSystemObject")
  'проверяем наличие папки по указанному пути
  If objFSO.FolderExists(sFolderName) = False Then
      MsgBox "Нет такой папки", vbCritical
      Exit Sub
  End If
  'перемещаем папку
  objFSO.MoveFolder sFolderName, sNewFolderName
  MsgBox "Папка перемещена", vbInformation
 
  Next

End Sub

Да, код там есть, но он для определённого наименования исходной папки, а как сделать список этих наименований?

Sub Move_Folder()
   Dim objFSO As Object
   Dim sFolderName As String, sNewFolderName As String
sFolderName = "C:\test"           'имя исходной папки
   sNewFolderName = "C:\tmp\test\"   'имя папки, в которую перемещаем(нужен слеш на конце)
   'создаем объект FileSystemObject    
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   'проверяем наличие папки по указанному пути
   If objFSO.FolderExists(sFolderName) = False Then
       MsgBox "Нет такой папки", vbCritical,
       Exit Sub
   End If
   'перемещаем папку
   objFSO.MoveFolder sFolderName, sNewFolderName
   MsgBox "Папка перемещена", vbInformation,
End Sub

Добрый день!
Нашла код переноса файлов с учётом расширения из одной папки в другую по списку:

Sub movefiles()
'Updateby Extendoffice
   Dim xRg As Range, xCell As Range
   Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
   Dim xSPathStr As Variant, xDPathStr As Variant
   Dim xVal As String
   On Error Resume Next
   Set xRg = Application.InputBox("Выбрать диапазон наименований:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
   If xRg Is Nothing Then Exit Sub
   Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
   xSFileDlg.Title = " Выбрать исходную папку:"
   If xSFileDlg.Show <> -1 Then Exit Sub
   xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
   Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
   xDFileDlg.Title = " Выбрать папку, куда переносится:"
   If xDFileDlg.Show <> -1 Then Exit Sub
   xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
   For Each xCell In xRg
       xVal = xCell.Value
       If TypeName(xVal) = "String" And xVal <> "" Then
           FileCopy xSPathStr & xVal, xDPathStr & xVal
           Kill xSPathStr & xVal
       End If
   Next
End Sub

Нужно выполнить аналогичную задачу, но для папок со всем содержимым.
Например есть папки 1, 2, 3, внутри которых есть файлы. Нужно перенести папки 1,2 со всем содержимым в новое расположение, а папку 3 со всем содержимым оставить.
Помогите пожалуйста!