Moving Folder to another Folder if name of folder and cell match

[aquse]

Hello everyone,


I basically need to move a folder containing to another folder if cell and name folder match. I got this code from the internet but it only moves files and the extension of the file needs to be included as well. However it does not move folders.

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("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)

    If xRg Is Nothing Then Exit Sub
       Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
       xSFileDlg.Title = " Please select the original folder:"
       If xSFileDlg.Show <> -1 Then Exit Sub
          xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
          Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
          xDFileDlg.Title = " Please select the destination folder:"
          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

How can i amend this code for it to move folders.

Thank you,

Aquse