Move complete folders into new created folders

[drag1c]

Hi all,

I am using, similar to code below, code to copy/create new folders and files inside new folders. Does anyone know how I can edit this code, to move folders based on Range?

Sub copyfiles()
Dim Cell As Range
Dim Foldername As String

Foldername = Range("F4").Text & " - " & Range("F3").Text

If Len(Dir("C:\Users\drag1c\Desktop\PROD\" & Foldername & "\", vbDirectory)) = 0 Then
        MkDir "C:\Users\drag1c\Desktop\PROD\" & Foldername & "\"
        MkDir "C:\Users\drag1c\Desktop\PROD\" & Foldername & "\" & "Pictures" & "\"
End If

Set fs = CreateObject("Scripting.FileSystemObject")
oldpath = "C:\Users\drag1c\Desktop\PROD\"
newpath = "C:\Users\drag1c\Desktop\PROD\" & Foldername & "\"
Set f = fs.GetFolder(oldpath)
Set NFile = f.Files
    For Each Cell In Worksheets("Sheet1").Range("E6:E10" & Cells(Rows.Count, 2).End(xlUp).Row)
        If Trim(Cell.Value) <> "" Then
            For Each pf1 In NFile
                NameFile = pf1.Name
                If InStr(NameFile, Cell.Value) > 0 Then
                  fs.MoveFolder Source:=oldpath, Destination:=newpath
                End If
            Next
        End If
    Next

End Sub

Part:

Set NFile = f.Files

I think here is problem how to get folder names, instead of file names.

Does anyone know how it should looks like?

 

[drag1c]

@Bump!

 

[drag1c]

Found a solution. Here below it is, if anyone ever needs it.

Key was in Set NFile = f.SubFolders

Sub movefiles()
Dim Cell As Range
Dim Foldername As String

Foldername = Range("F4").Text & " - " & Range("F3").Text

If Len(Dir("C:\Users\drag1c\Desktop\PROD\" & Foldername & "\", vbDirectory)) = 0 Then
        MkDir "C:\Users\drag1c\Desktop\PROD\" & Foldername & "\"
        MkDir "C:\Users\drag1c\Desktop\PROD\" & Foldername & "\" & "Pictures" & "\"
End If

Set fs = CreateObject("Scripting.FileSystemObject")
oldpath = "C:\Users\drag1c\Desktop\PROD\"
newpath = "C:\Users\drag1c\Desktop\PROD\" & Foldername & "\"
Set f = fs.GetFolder(oldpath)
Set NFile = f.SubFolders
    For Each Cell In Worksheets("Sheet1").Range("E6:E10" & Cells(Rows.Count, 2).End(xlUp).Row)
        If Trim(Cell.Value) <> "" Then
            For Each pf1 In NFile
                NameFile = pf1.Name
                If InStr(NameFile, Cell.Value) > 0 Then
                  fs.MoveFolder oldpath & "\" & NameFile, newpath & "\" & NameFile
                End If
            Next
        End If
    Next

End Sub