New Folders From Selected Range (Cells) With A Workbook Copied To Each

Oakwoodbespoke

New Member
Joined
Jun 27, 2023
Messages
21
Office Version
  1. 365
Platform
  1. Windows
Hi,

I'm trying to do the following:

I have a list of job numbers with their relevant site addresses (I have made them as one with CONCATENATE in Column E)

I have managed to get things to work so you can select cells in Column E and it will create new folders within a Folder named "New Folder 2" on the desk top

What I would like it to do is once the new folders are created it copies a Excell workbook from a specified location and adds it to each newly created folder.

Thanks in advance for any help




Sub MakeFolders()
Dim dirName As String
Dim selectedRange As Range
Dim cell As Range
Dim i As Long

' Prompt user to select a range of cells
Set selectedRange = Application.InputBox("Select a range of cells:", "Select Range", Type:=8)

' Check if a range was selected
If Not selectedRange Is Nothing Then

' Create folders based on cell values
On Error Resume Next ' Enable error handling
For Each cell In selectedRange
dirName = cell.Value
MkDir "c:\Users\xxusernamexx\Desktop\New Folder 2\" & dirName

Next cell
On Error GoTo 0 ' Reset error handling

MsgBox "Folders have been created successfully!", vbInformation
Else
MsgBox "No range selected. Operation cancelled.", vbInformation
End If
End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Hi saboh12617
Thanks again for your help on this, as a step further ive worked out how to automatically open the newly created spreadsheet using Workbooks.Open

It would be good to automatically populate say cell c10 with the job number and C11 with the job title taken from filename (see below)

' new file name
Dim fileName As String: fileName = dirName & " Account Spreadsheet" & ".xlsx"


(is it possible to use left, mid and right specified number of characters as in a normal formula)

As the file name contains the job number and the title
job number is always 4 digits followed by space and then title

so ideally c10 should be the first 4 digits
and then c11 should start at character 6
 
Upvote 0
Hi saboh12617

Thanks again for your help on this, as a step further ive worked out how to automatically open the newly created spreadsheet using Workbooks.Open

It would be good to automatically populate say cell c10 with the job number and C11 with the job title taken from filename (see below)

' new file name
Dim fileName As String: fileName = dirName & " Account Spreadsheet" & ".xlsx"


(is it possible to use left, mid and right specified number of characters as in a normal formula)

As the file name contains the job number and the title
job number is always 4 digits followed by space and then title

so ideally c10 should be the first 4 digits
and then c11 should start at character 6
 
Upvote 0
Hello,

Yes it is possible. One way to do it is like in the sub below, with your file name looking like this:
[JOB NUM] [JOB TITLE] Account spreadsheet.xlsx
1234 6789 Account spreadsheet.xlsx

VBA Code:
Sub example(fileName As String, dirName As String)
  ' i suppose fileName always like:
  ' "1234 6789 Account Spreadsheet.xlsx"
  ' and dirName being the one defined in your post
  
  Dim filePath As String
  filePath = "c:\Users\xxusernamexx\Desktop\New Folder 2\" & dirName & "\" & fileName
  
  ' verify file exists
  If Dir(filePath) <> vbNullString Then
    With Workbooks.Open(filePath)
      ActiveSheet.Range("C10").Value2 = Left$(fileName, 4)
      ActiveSheet.Range("C11").Value2 = Mid$(fileName, 6, 4)
      .Save
      
      ' optional: automatically closed
      '.Close
    End With
  End If

End Sub
 
Upvote 0
Hi Saboh12617

When the new folder is created and the spreadsheet is copied into that folder can the spreadsheet be updated with the relevant information then (c10 & c11)

I would also like the newly copied and updated spreadsheet to stay open

Or does it have to be done as a separate code ?
 
Upvote 0
i currently have the following code (would be amazing if you could add the new code to the one below) (xxxxxxxxx to protect privacy)
I really appreciate this

Sub MakeFolders()
Dim dirName As String
Dim selectedRange As Range
Dim cell As Range
Dim i As Long


' Prompt user to select a range of cells
Set selectedRange = Application.InputBox("Select a range of cells:", "Select Range", Type:=8)

' Check if a range was selected
If Not selectedRange Is Nothing Then

' Create folders based on cell values
On Error Resume Next ' Enable error handling
For Each cell In selectedRange
dirName = cell.Value

' folder creation
MkDir "O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName

' path to file to copy
Dim filePath As String: filePath = "O:\000. xxxxxxxxx\4. Quotations\0000 - Quotation - Summary Template (Version. 24.3).xlsx"

' new file name
Dim fileName As String: fileName = dirName & " - Quotation - Summary Template" & ".xlsx"

' copy
FileCopy filePath, "O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName & "\" & fileName

'open the workbook in the new folder
Workbooks.Open ("O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName & "\" & fileName)

Next cell


On Error GoTo 0 ' Reset error handling

MsgBox "Folders have been created successfully!", vbInformation
Else
MsgBox "No range selected. Operation cancelled.", vbInformation
End If
End Sub
 
Upvote 0
Hello,
Yes you can add the example i gave you in your code like so (look at the rows before "next cell". The workbooks are kept open.
(please use code markers thank you)
VBA Code:
Sub MakeFolders()
  Dim dirName As String
  Dim selectedRange As Range
  Dim cell As Range
  Dim i As Long


  ' Prompt user to select a range of cells
  Set selectedRange = Application.InputBox("Select a range of cells:", "Select Range", Type:=8)

  ' Check if a range was selected
  If Not selectedRange Is Nothing Then

    ' Create folders based on cell values
    On Error Resume Next                         ' Disable error handling
    For Each cell In selectedRange
      dirName = cell.Value

      ' folder creation
      MkDir "O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName

      ' path to file to copy
      Dim filePath As String: filePath = "O:\000. xxxxxxxxx\4. Quotations\0000 - Quotation - Summary Template (Version. 24.3).xlsx"

      ' new file name
      Dim fileName As String: fileName = dirName & " - Quotation - Summary Template" & ".xlsx"

      ' copy
      FileCopy filePath, "O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName & "\" & fileName

      'open the workbook in the new folder
      With Workbooks.Open("O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName & "\" & fileName)
        ' updating values
        ActiveSheet.Range("C10").Value2 = Left$(fileName, 4)
        ActiveSheet.Range("C11").Value2 = Mid$(fileName, 6, 4)
        .Save
        ' optional: automatically closed
        '.Close
      End With
    Next cell


    On Error GoTo 0                              ' Reset error handling

    MsgBox "Folders have been created successfully!", vbInformation
  Else
    MsgBox "No range selected. Operation cancelled.", vbInformation
  End If
End Sub
 
Upvote 0
Hi,

That works great thanks

Just one final thing

Out of interest how would i reference another cell from another sheet as this would be really useful to

for example
' updating values
ActiveSheet.Range("C10").Value2 = this would be a path to another workbook, spreadsheet (Sheet31) and cell
 
Upvote 0
Hello,

I recommend you to have a look at some VBA tutorials as you would find a lot of your answers easily.

To get the value of the cell of another workbook, you need two steps:

1) 1st open the other workbook.

2) Then use
VBA Code:
Workbooks("destination").Worksheets("sht_to_write").Range("address_to_edit").Value2 = Workbooks("opened_wb").Worksheets("sht_to_read").Range("address_to_copy").Value2

Notice i did not use "Activesheet" as this can get very messy since opening a new workbook changes the activesheet to this new workbook. It is always good practice (>> less bugs) to reference sheets as i did here, even if it makes the code a bit longer.
 
Upvote 0

Forum statistics

Threads
1,226,453
Messages
6,191,136
Members
453,642
Latest member
jefals

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