VBA to copy/rename files

[three482]

Hi everyone. I’m trying to copy a prebuilt template (“C:\Users\macros\monthly log.xlsm”) and save a copy of the workbook for team members based on a list that includes the current month (for example, “C:\Users\Accounting\Sept monthly log (John Smith).xlsm”, where cell A1 = Accounting and A2 = John Smith). Ideally, I’d like to list other teams in separate columns (like B1 = Service and B2 = Jane Smith). The team rosters are maintained in a separate workbook (rosters.xlsx). Teams are also different sizes - some could have 8, another 15, and another 12.

I hope I have adequately described what I’m looking to accomplish.

Thanks in advance!

 

[ranman256]

1. paste code into a module,

2. then put
the Depts in col.A
employees in col.B

like:
DEPT EMPLOYEE
Accouting PETER PARKER
Accouting MARY JANE WATSON
Service STEVE ROGERS
Service TONY STARK
Maintenance BRUCE BANNER
Maintenance THOR ODINSON


3. edit the path of the TEMPLATE FILE in the code below

4. run: CreateFiles

Sub CreateFiles()
Dim vName, vDept, vTargDir, vTargFile
Dim vMonth

Const kBaseDir = "c:\users\"
Const kTemplateFile = "c:\temp\template2Use.xlsm"

vMonth = InputBox("Enter Month (MMM)", "Enter the month name")
If vMonth = "" Then Exit Sub

'all depts in col.A
'all empoyee names in col.B

MakeDir kBaseDir


'cycle thru the list getting names & depts
Range("A2").Select
While ActiveCell.Value <> ""
   vDept = ActiveCell.Value
   vName = ActiveCell.Offset(0, 1).Value
   
   'prep the target file
   vTargDir = kBaseDir & vDept
   MakeDir vTargDir
   vTargFile = vTargDir & "\" & vMonth & " Monthly Log(" & vName & ").xlsm"
   
    'copy the template
   Copy1File kTemplateFile, vTargFile
   
   ActiveCell.Offset(1, 0).Select 'next row
Wend
MsgBox "Done"
End Sub


Private Sub MakeDir(ByVal pvDir)
Dim fso
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(pvDir) Then fso.CreateFolder pvDir     'MkDir pvDir

Set fso = Nothing
End Sub


Private Function Copy1File(ByVal pvSrc, ByVal pvTarg) As Boolean
Dim fso
On Error GoTo errMake

Set fso = CreateObject("Scripting.FileSystemObject")    '(reference: ms Scripting Runtime)
fso.CopyFile pvSrc, pvTarg
Copy1File = True
Set fso = Nothing
Exit Function

errMake:
'MsgBox Err.Description & vbCrLf & pvSrc, , "Copy1File(): " & Err
Set fso = Nothing
End Function