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

[Oakwoodbespoke]

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

 

[Oakwoodbespoke]

Cant for the life of me get it to work, could you kindly add the code above to the main code please replacing the code below

' updating values
ActiveSheet.Range("C10").Value2 = Left$(fileName, 4)
ActiveSheet.Range("C11").Value2 = Mid$(fileName, 6, 4)

 

[saboh12617]

Sorry but i do not have the required information to do so.
I need the path, the name, the sheet's name, and the range of the workbook from which you take the values.
Also if you'd have explained it all at the beginning it would have been easier.
Also there is a lot of information on Google when you type "VBA copy values from one workbook to another".

 

[Oakwoodbespoke]

Understood

Workbooks("destination").Worksheets("sht_to_write").Range("address_to_edit").Value2 = Workbooks("opened_wb").Worksheets("sht_to_read").Range("address_to_copy").Value2

destination= O:\000. xxxxxxxxxxxx\2. Accounts\Invoices\" & dirName & "\" & fileName
sht_to_write= Sheet1 (Summary)
address_to_edit= C10

opened_wb= "O:\000. xxxxxxxxxxxx\2. Accounts\2024 Account Spreadsheets\2024-04 xxxxx ACCOUNTS SUMMARY .xlsm"
sht_to_read= Sheet31 (Accounts)
address_to_copy= column B, and ideally the row selected at the beginning of the code when the range was selected

Thanks again much appreciated

 

[saboh12617]

Okay thanks for the informations. As i understood the workbook that you take values from is the workbook running the macro, therefore i simply wrote "ThisWorkbook".

Please find below your code, i took the occasion to review a few things to make it easier to maintain/read.

I made variables so that you can adapt the sheets names/cells addresses if needed, without modifying the code below. You just need to edit the variables.

I can not test it unfortunately, so tell me if it works.

PS : since you said nothing about cell C11 i did not modify it, however you can follow the same principle as the row above it to make it read from the main workbook too.

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

  ' 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 selectedRange Is Nothing Then
    MsgBox "No range selected. Operation cancelled.", vbInformation
    Exit Sub
  End If
  
  ' Create folders based on cell values
  ' On Error Resume Next                 ' Disable error handling
  For Each cell In selectedRange
    dirName = cell.Value

    ' folder creation
    On Error Resume Next
    MkDir "O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName
    On Error GoTo 0

    ' 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 and edit some values based on this workbook values
    Dim mainWb As Workbook: Set mainWb = ThisWorkbook
    Dim shtToRead As String: shtToRead = "Accounts"
    Dim addrToCopy As String: addrToCopy = "B" & cell.Row

    Dim shtToWrite As String: shtToWrite = "Summary"
    Dim addrToEdit As String: addrToEdit = "C10"

    With Workbooks.Open("O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName & "\" & fileName)
      ' updating values
      .Worksheets(shtToWrite).Range(addrToEdit).Value2 = _
        mainWb.Worksheets(shtToRead).Range(addrToCopy).Value2
        
      .Worksheets(shtToWrite).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
End Sub

 

[Oakwoodbespoke]

Okay thanks for the informations. As i understood the workbook that you take values from is the workbook running the macro, therefore i simply wrote "ThisWorkbook".

Please find below your code, i took the occasion to review a few things to make it easier to maintain/read.

I made variables so that you can adapt the sheets names/cells addresses if needed, without modifying the code below. You just need to edit the variables.

I can not test it unfortunately, so tell me if it works.

PS : since you said nothing about cell C11 i did not modify it, however you can follow the same principle as the row above it to make it read from the main workbook too.

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

  ' 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 selectedRange Is Nothing Then
    MsgBox "No range selected. Operation cancelled.", vbInformation
    Exit Sub
  End If
 
  ' Create folders based on cell values
  ' On Error Resume Next                 ' Disable error handling
  For Each cell In selectedRange
    dirName = cell.Value

    ' folder creation
    On Error Resume Next
    MkDir "O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName
    On Error GoTo 0

    ' 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 and edit some values based on this workbook values
    Dim mainWb As Workbook: Set mainWb = ThisWorkbook
    Dim shtToRead As String: shtToRead = "Accounts"
    Dim addrToCopy As String: addrToCopy = "B" & cell.Row

    Dim shtToWrite As String: shtToWrite = "Summary"
    Dim addrToEdit As String: addrToEdit = "C10"

    With Workbooks.Open("O:\000. xxxxxxxxx\2. Accounts\Invoices\" & dirName & "\" & fileName)
      ' updating values
      .Worksheets(shtToWrite).Range(addrToEdit).Value2 = _
        mainWb.Worksheets(shtToRead).Range(addrToCopy).Value2
       
      .Worksheets(shtToWrite).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
End Sub

Fantastic, works brilliantly, I also successfully added more variables

Thank so much again for all your help

 

[saboh12617]

Good, i'm glad it works for you. Thanks for the feedback & have a good day.

 

[Oakwoodbespoke]

Good, i'm glad it works for you. Thanks for the feedback & have a good day.

Thanks a lot for your help