Copy folder and rename based on cell value VBA?

[Viperuk]

Hi all.

I am trying to create some code which will copy the contents of a template folder and rename it based on a cell value or cpoy the contents into a new folder created by excel.

I can create a new dir based on a cell value but cannot copy and paste into it.

Not sure how to enter the code so I have pasted below.



'Insert form details code


Private Sub Submitbutton_Click()




Dim emptyRow As Long



Worksheets("Data").Activate

emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1

'Transfer information
Cells(emptyRow, 1).Value = Range("A4").FormulaR1C1
Cells(emptyRow, 2).Value = FirstNameBox.Value
Cells(emptyRow, 3).Value = LastNameBox.Value
Cells(emptyRow, 4).Value = Classificationbox.Value
Cells(emptyRow, 5).Value = Sitename.Value
Cells(emptyRow, 6).Value = DateofInjuryBox.Text
Cells(emptyRow, 7).Value = ReturnDateBox.Text
Cells(emptyRow, 8).Value = Range("H1").FormulaR1C1
Cells(emptyRow, 9).Value = DivisionCombo.Value
Cells(emptyRow, 10).Value = Accidentbookref.Value
Cells(emptyRow, 11).Value = InjuryCatCombo.Value
Cells(emptyRow, 12).Value = BodyAreaInjuryCombo.Value
Cells(emptyRow, 13).Value = LocationInjuryCombo.Value
Cells(emptyRow, 14).Value = ReportableYN.Value
Cells(emptyRow, 15).Value = Status.Value
Cells(emptyRow, 16).Value = Completedby.Value



'Make new Dir based on last entry value in WS location

MkDir ThisWorkbook.Path & "" & Range("R2").Value & " " & "Incident Folder"



'Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.

Dim FSO As Object
Dim FromPath As String
Dim ToPath As String


FromPath = ThisWorkbook.Path & "\Template"
ToPath = ThisWorkbook.Path & "" & Range("R2").Value & " " & "Incident Folder"



ThisWorkbook.Save

End Sub

 

[James006]

Hello,

You could test the following :

ActiveWorkbook.SaveAs ("C:" & ThisWorkbook.Path & " " & Range("R2").Value & " " & "Incident Folder" & ".xlsx")

HTH

 

[Viperuk]

Hello,

You could test the following :

ActiveWorkbook.SaveAs ("C:" & ThisWorkbook.Path & " " & Range("R2").Value & " " & "Incident Folder" & ".xlsx")

HTH

Hello James.

Thank you for your assistance, however.

The code appears to save the WB as and rename as R2 value.

What I would like my code to do is once it has entered the details via the userform into the table do one of two things.

1 - Copy the template folder as a whole, which is in the same Dir as the open WB (this folder holds a series of sub folders which are required for accident investigation) and rename the folder based on a cell value (R2) & " Incident Folder" which is the last assigned serial number in the table.

or

2 - Copy all of the sub folders within the 'template folder' and paste them into the newly created folder which is named based on cell value R2.

My code is half way there, it follows 2 as above and creates a new folder and names it as cell R2 value & "Incident Folder" but I am struggling with copying the sub folders from 'template folder' into the new folder.

Hope that explains it better.

Thank you

 

[James006]

Hello again,

Indeed ... with you new explanation ... what you are after is quite different from what I had initially understood ...

If I recall correctly Ron DeBruin has designed a very efficient solution ... for copying folders including all sub-folders ...

Copy and Move files and folders

Hope this will help

Cheers

James

 

[Viperuk]

Hello again,

Indeed ... with you new explanation ... what you are after is quite different from what I had initially understood ...

If I recall correctly Ron DeBruin has designed a very efficient solution ... for copying folders including all sub-folders ...

Copy and Move files and folders

Hope this will help

Cheers

James

Hello James, Many thanks.. That has got it working.


Code below.








Private Sub Submitbutton_Click()


Dim emptyRow As Long

'Make Sheet1 active
Worksheets("Data").Activate

'Determine emptyRow
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1

'Transfer information
Cells(emptyRow, 1).Value = Range("A4").FormulaR1C1
Cells(emptyRow, 2).Value = FirstNameBox.Value
Cells(emptyRow, 3).Value = LastNameBox.Value
Cells(emptyRow, 4).Value = Classificationbox.Value
Cells(emptyRow, 5).Value = Sitename.Value
Cells(emptyRow, 6).Value = DateofInjuryBox.Text
Cells(emptyRow, 7).Value = ReturnDateBox.Text
Cells(emptyRow, 8).Value = Range("H1").FormulaR1C1
Cells(emptyRow, 9).Value = DivisionCombo.Value
Cells(emptyRow, 10).Value = Accidentbookref.Value
Cells(emptyRow, 11).Value = InjuryCatCombo.Value
Cells(emptyRow, 12).Value = BodyAreaInjuryCombo.Value
Cells(emptyRow, 13).Value = LocationInjuryCombo.Value
Cells(emptyRow, 14).Value = ReportableYN.Value
Cells(emptyRow, 15).Value = Status.Value
Cells(emptyRow, 16).Value = Completedby.Value




'Make new folder based on last entry value in WS location

MkDir ThisWorkbook.Path & "" & Range("R2").Value & " " & "Incident Folder"




Dim FSO As Object
Dim FromPath As String
Dim ToPath As String


FromPath = ThisWorkbook.Path & "\Template"
ToPath = ThisWorkbook.Path & "" & Range("R2").Value & " " & "Incident Folder"



If Right(FromPath, 1) = "" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If


If Right(ToPath, 1) = "" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If


Set FSO = CreateObject("scripting.filesystemobject")


If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If


FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath




ThisWorkbook.Save



End Sub

 

[James006]

Glad you could solve your problem ...

Thanks for sharing your final solution for the benefit of All readers ...