Create folder, subfolders and move files into folder and subfolders

[willow1985]

I have the below code that will create folders based on a selected range of folder names in a column but I want to take this further and do not know where to begin.
First I need this modified that it will create folders in a directory of your choosing NOT where the spreadsheet is located.
It will make all the folder names listed in column A in the directory listed in B. Then it will make 2 Subfolders: Documents and Drawing in each primary folder and copy documents into those sub folders (or where ever it is specified to save it).

I hope I am explaining things properly and I hope someone can help me modify the below code or if anyone knows of a better one?

I am still new to this and the users who want to use this file want it to be customizable so the details are in the below sheet.

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Book3
	A	B	C	D	E	F	G	H	I
1	Folder	Folder Location	Sub Folder 1	Sub Folder 2	Copy Document File to Location	Copy Map File to Location		Directory of Draft Document File:	Directory of Draft Map File:
2	AXX4522	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4522\Documents	\\Usa-files\Quality\AXX4522\Drawing		\\Usa-files\Quality\2021 - Fall\Document Draft.docx	\\usa-files\Quality\Quality Assurance\Drafts\Map Draft.xlsx
3	AXX4523	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4523\Documents	\\Usa-files\Quality\AXX4523\Drawing
4	AXX4524	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4524\Documents	\\Usa-files\Quality\AXX4524\Drawing
5	AXX4525	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4525\Documents	\\Usa-files\Quality\AXX4525\Drawing
6	AXX4526	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4526\Documents	\\Usa-files\Quality\AXX4526\Drawing
7	AXX4527	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4527\Documents	\\Usa-files\Quality\AXX4527\Drawing
8	AXX4528	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4528\Documents	\\Usa-files\Quality\AXX4528\Drawing
9	AXX4529	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4529\Documents	\\Usa-files\Quality\AXX4529\Drawing
10	AXX4530	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4530\Documents	\\Usa-files\Quality\AXX4530\Drawing
11	AXX4531	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4531\Documents	\\Usa-files\Quality\AXX4531\Drawing
12	AXX4532	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4532\Documents	\\Usa-files\Quality\AXX4532\Drawing
13	AXX4533	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4533\Documents	\\Usa-files\Quality\AXX4533\Drawing
14	AXX4534	\\Usa-files\Quality\	Documents	Drawing	\\Usa-files\Quality\AXX4534\Documents	\\Usa-files\Quality\AXX4534\Drawing
Sheet1

Cell Formulas
Range	Formula
E2:E14	E2	="\\Usa-files\Quality\"&A2&"\"&C2
F2:F14	F2	="\\Usa-files\Quality\"&A2&"\"&D2

 

[Marc L]

Then it will make 2 Subfolders: Documents and Drawing in each primary folder and copy documents into those sub folders

Which documents : those in H2:I2 ? Both to each subfolders ?​

 

[Marc L]

As under a VBA procedure columns E & F are useless : do you want to keep them or they can be removed ?​

 

[willow1985]

I was able to figure it out using the below set up:

Folder-Sub Folder and File Copy Macro.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Folders	File Name	File Source	File Destination	Sub Folder Name			Root Folder	Sub Folder Name (MAX 2 Sub Folders)		Sub Folder Name for File Destination	File Name	File Source
2	Folder1	Blank Form.xlsx	C:\Test\Documents	C:\Test\Folder1\Name1	Name1			C:\Test	Name1		Name1	Blank Form.xlsx	C:\Test\Documents
3	Folder2	Blank Form.xlsx	C:\Test\Documents	C:\Test\Folder2\Name1	Name1				Name2
4	Folder3	Blank Form.xlsx	C:\Test\Documents	C:\Test\Folder3\Name1	Name1				Name3
5	Folder4	Blank Form.xlsx	C:\Test\Documents	C:\Test\Folder4\Name1	Name1
Macro

Cell Formulas
Range	Formula
B2:B5	B2	=$L$2
C2:C5	C2	=$M$2
D2:D5	D2	=$H$2&"\"&A2&"\"&$K$2
E2:E5	E2	=$K$2

The first button (vba code) creates the folders and subfolders:

Sub CreateDirs()
    Dim r As Range
    Dim RootFolder As String
    RootFolder = Range("H2").Value
Range("A2").Select

    For Each r In Range(Selection, Selection.End(xlDown))
        If Len(r.Text) > 0 Then
            On Error Resume Next
            MkDir RootFolder & "\" & r.Text
            MkDir RootFolder & "\" & r.Text & "\" & Range("I2").Value
            MkDir RootFolder & "\" & r.Text & "\" & Range("I3").Value
            MkDir RootFolder & "\" & r.Text & "\" & Range("I4").Value
            On Error GoTo 0
        End If
Next r


End Sub

The Second button (VBA code) allows me to transfer the files to the folders and subfolders, or just the main folders if I leave the subfolders blank.

Sub File_Transfer()
'

Dim src As String, dst As String, fl As String
Dim lr As Long
'Source directory
'Range("A2").Select
lr = Cells(Rows.Count, "C").End(xlUp).Row
For X = 2 To lr
src = Range("C" & X).Value
'Destination directory
dst = Range("D" & X).Value
'Filename
fl = Range("B" & X).Value
On Error Resume Next
'get project id
FileCopy src & "\" & fl, dst & "\" & fl
If Err.Number <> 0 Then


End If
Next X
On Error GoTo 0
End Sub

Hope this helps someone out there and thank you to all who responded/attempted to help me when I got stuck. You are all awesome and it is much appreciated!