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
 
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: 5
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

O
  • Solved
New Folders From Selected Range (Cells) With A Workbook Copied To Each
2 3
Replies
26
Views
344
Oakwoodbespoke
O
D
  • Question Question
Can't get folder to create on desktop. When debugging it shows no errors.
2 3
Replies
24
Views
599
jolivanes
jolivanes
R
  • Solved
Export excel file as PDF into a targeted pc folder based on cell value
Replies
2
Views
354
Ramadan
R
A
  • Question Question
Restrict move files from folders and subfolders to new folders based on files names
Replies
0
Views
276
Abdo
A
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M

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