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

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 со всем содержимым оставить.
Помогите пожалуйста!