creating new folder by Copying folder template and naming it with cell value

D

DrMaghrabi

New Member
Joined
Oct 10, 2023
Messages
7
Office Version
  1. 2019
Platform
  1. Windows
Hello!

can someone help me in creating a code to perform the following: (NB. I don't Know coding)

I have an excel file contain a column with series no. (1,2,3,etc..) and a folder [named: Customers] contain folders named correspondingly but with leading zeros for the purpose of sorting thing as ( 0001, 0002, 0003, etc...)
I want when I add new number in the list [for ex: 52], it creates a new folder by copying the template Folder [new](in the folder: Customers) and its files content and name it [0052] and make the cell hyperlinked to this folder, so it opens the folder when I click on the number.

Thank you
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
Hi @DrMaghrabi

Here is a VBA Code that will do the job:

VBA Code: 
Public fPat As String
Public tPat As String

Public Sub MySub()
   fPat = "C:\TEMP\MrExcel\DrMaghrabi\Customers" '<--- CHANGE PATH TO MATCH YOUR DESTINATION
   tPat = "C:\TEMP\MrExcel\DrMaghrabi\template" '<--- CHANGE PATH TO MATCH YOUR DESTINATION
   Call demo
End Sub

Private Sub demo()
   Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
   Dim ws As Worksheet
   Set ws = ThisWorkbook.Sheets("Sheet1")
   Dim rng As Range
   Set rng = ws.Range("A2:A1048576")
   Dim cel As Range
   Dim fol As String
  
   For Each cel In rng.Cells
      If cel.Value2 = "" Then Exit For
      If IsNumeric(cel.Value2) = False Then GoTo skip
      fol = x(cel.Value2)
      Select Case fol
         Case "Err"
            Debug.Print "An Error occured. Please review data."
            GoTo skip
         Case Else
            If (Dir(fPat & "\" & fol, vbDirectory) = "") Then
               fso.CopyFolder tPat, fPat & "\" & fol
            End If
         End Select
skip:
   Next cel
End Sub

Private Function x(val As Variant) As String
   Select Case Len(val)
      Case 1
         x = "000" & val
      Case 2
         x = "00" & val
      Case 3
         x = "0" & val
      Case 4
         x = val
      Case Else
         x = "Err"
   End Select
End Function

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Call MySub
End Sub

Now you need to paste the code in the right place and save the file as "Excel Macro-Enabled Workbook (*.xlsm)" in order to work.

Here's how to do it:

  1. Press keys [Alt]+[F11] to open the VBA Editor
  2. Press [Ctrl]+[R] to open the Project Explorer (if not already opened)
  3. In the "Microsoft Excel Objects" Section go to "ThisWorkbook", right-click on it and then "View Code":
    1697155371151.png
  4. From the top left dropdown select "Workbook"
    1697155416034.png
  5. In the top right dropdown select "SheetChange"
    1697155559644.png
  6. Now you should see the Code Window (colors will differ)
    1697155661705.png

    This is where you paste the VBA code
  7. In the end it should look like this:
    1697156017101.png
Let me know if you need further assistance.

________________________________________
EDIT: Forgot about the hyperlinks. I'll check that tomorrow. It's bedtime...
 
Upvote 0
PeteWright said:
Hi @DrMaghrabi

Here is a VBA Code that will do the job:

VBA Code: 
Public fPat As String
Public tPat As String

Public Sub MySub()
   fPat = "C:\TEMP\MrExcel\DrMaghrabi\Customers" '<--- CHANGE PATH TO MATCH YOUR DESTINATION
   tPat = "C:\TEMP\MrExcel\DrMaghrabi\template" '<--- CHANGE PATH TO MATCH YOUR DESTINATION
   Call demo
End Sub

Private Sub demo()
   Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
   Dim ws As Worksheet
   Set ws = ThisWorkbook.Sheets("Sheet1")
   Dim rng As Range
   Set rng = ws.Range("A2:A1048576")
   Dim cel As Range
   Dim fol As String
 
   For Each cel In rng.Cells
      If cel.Value2 = "" Then Exit For
      If IsNumeric(cel.Value2) = False Then GoTo skip
      fol = x(cel.Value2)
      Select Case fol
         Case "Err"
            Debug.Print "An Error occured. Please review data."
            GoTo skip
         Case Else
            If (Dir(fPat & "\" & fol, vbDirectory) = "") Then
               fso.CopyFolder tPat, fPat & "\" & fol
            End If
         End Select
skip:
   Next cel
End Sub

Private Function x(val As Variant) As String
   Select Case Len(val)
      Case 1
         x = "000" & val
      Case 2
         x = "00" & val
      Case 3
         x = "0" & val
      Case 4
         x = val
      Case Else
         x = "Err"
   End Select
End Function

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Call MySub
End Sub

Now you need to paste the code in the right place and save the file as "Excel Macro-Enabled Workbook (*.xlsm)" in order to work.

Here's how to do it:

  1. Press keys [Alt]+[F11] to open the VBA Editor
  2. Press [Ctrl]+[R] to open the Project Explorer (if not already opened)
  3. In the "Microsoft Excel Objects" Section go to "ThisWorkbook", right-click on it and then "View Code":
    View attachment 100253
  4. From the top left dropdown select "Workbook"
    View attachment 100254
  5. In the top right dropdown select "SheetChange"
    View attachment 100255
  6. Now you should see the Code Window (colors will differ)
    View attachment 100256
    This is where you paste the VBA code
  7. In the end it should look like this:
    View attachment 100257
Let me know if you need further assistance.

________________________________________
EDIT: Forgot about the hyperlinks. I'll check that tomorrow. It's bedtime...
Click to expand...
Thank you very much for your help
I have this message
1698144182603.png
 

Attachments

  • 1698144005089.png
    1698144005089.png
    152.1 KB · Views: 1
Upvote 0
I have just tested some code and it also works.
The only thing that changes is a new line with ws.Hyperlinks.Add cel, FolderPath & "\" & fol

Here is the updated code:
VBA Code: 
Public fPat As String
Public tPat As String

Public Sub MySub()
   fPat = "C:\TEMP\MrExcel\DrMaghrabi\Customers" '<--- CHANGE PATH TO MATCH YOUR DESTINATION
   tPat = "C:\TEMP\MrExcel\DrMaghrabi\template" '<--- CHANGE PATH TO MATCH YOUR DESTINATION
   Call demo
End Sub

Private Sub demo()
   Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
   Dim ws As Worksheet
   Set ws = ThisWorkbook.Sheets("Sheet1")
   Dim rng As Range
   Set rng = ws.Range("A2:A1048576")
   Dim cel As Range
   Dim fol As String
  
   For Each cel In rng.Cells
      If cel.Value2 = "" Then Exit For
      If IsNumeric(cel.Value2) = False Then GoTo skip
      fol = x(cel.Value2)
      Select Case fol
         Case "Err"
            Debug.Print "An Error occured. Please review data."
            GoTo skip
         Case Else
            If (Dir(fPat & "\" & fol, vbDirectory) = "") Then
               fso.CopyFolder tPat, fPat & "\" & fol
               ws.Hyperlinks.Add cel, FolderPath & "\" & fol '<--- NEW CODE
            End If
         End Select
skip:
   Next cel
End Sub

Private Function x(val As Variant) As String
   Select Case Len(val)
      Case 1
         x = "000" & val
      Case 2
         x = "00" & val
      Case 3
         x = "0" & val
      Case 4
         x = val
      Case Else
         x = "Err"
   End Select
End Function

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Call MySub
End Sub

Try it out.
 
Upvote 0
I'm following this with great interest. My old feeble mind is having a difficult time understanding how his folders, template etc are all situated
on his machine. I've attempted several passes at creating the various folders but no success.

Could someone hold my hand through creating that process ? Thank you.
 
Upvote 0
Logit said:
I'm following this with great interest. My old feeble mind is having a difficult time understanding how his folders, template etc are all situated
on his machine. I've attempted several passes at creating the various folders but no success.

Could someone hold my hand through creating that process ? Thank you.
Click to expand...
Hi @Logit
What is it that you need to do and how can I help?
 
Upvote 0
I don't understand his description of the various existing folders and what the folders contain.
 
Upvote 0
Alright, I'll try to explain...

He has the following folder structure somewhere on the hard drive:

|-[Customers]
|--[0001]
|--[0002]
|--[0003]
|--[0004]

That is one main folder called "Customers" and within that folder he has one subfolder for each customer ("0001", "0002", "0003", etc.)

Than there is a template folder containing sample data and subfolders:

|-[Template]
|--[DummyFolder1]
|---DummyFile1.1.txt
|--[DummyFolder2]
|---DummyFile2.1.txt
|--[DummyFolder3]
|---DummyFile3.1.txt
|--DummyFile1.txt
|--DummyFile2.txt
|--DummyFile3.txt

Now, the aim of this VBA Macro is to copy the complete template folder to a new created subfolder within the "Customers" folder each time a cell value was changed.


I hope this is a little more clear now.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
For each row, create new folder based on single cell value, then save exported XML doc to matching folder.
Replies
3
Views
176
shand
S
H
  • Question
VBA code Required For Deleting A Folder then Copying Files From Another Folder
Replies
1
Views
125
hrayani
H
A
  • Solved
Copying files to a newly created folder named from data within spreadsheet
Replies
2
Views
220
AndyEd
A
C
  • Solved
VBA listing folders, sub-folders & file names - modification required
Replies
5
Views
408
NdNoviceHlp
NdNoviceHlp
S
  • Solved
VBA Code to select a variable folder path, find multiple .xls then copy same named worksheets into new workbook.
Replies
4
Views
441
SteveD01
S

Forum statistics

Threads
1,215,073
Messages
6,122,975
Members
449,095
Latest member
Mr Hughes

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top