VBA - Use .xlsm file as a template and saving based on names in a list

[AAW425]

Hello!
I have created a macro-enabled workbook that I would now like to use as a template. My goal is to have this file (we'll call it workbook1.xlsm) save multiple times in a specific folder (Folder 1) based on a list of names with the macros from the original file intact. I am trying to have this automated in vba given that I will ultimately end up with 150+files.

Ultimately, the output will be Folder 1 containing 150 workbooks identical to the original but named after the person in the list.

I have found other solutions, however I cannot get any of the codes modified to work for .xlsm.

Thank you!

 

[pbornemeier]

If you save it as a template file (.xltx) then when it is opened it will have to be saved as a standard file.
Either as a template or .xlsm you can use another program that contains the new names to duplicate the original program.

.xlsb files are smaller that .xlsm files and load faster. I would use that format unless there is some reason not to do so.

BEEN THERE/DONE THAT WARNING: Have you set up the workbook so data contained in it can be easily moved to a new version of the workbook? Perhaps all located on a few worksheets? Be sure to put a version number in your original file so when you make a change to it (and it WILL happen sooner or later) and you have to upgrade the 150 copies, you can easily import the data to the new version.

Option Explicit

Sub FileCopier()

    Dim rngNames As Range
    Dim sOriginalFilepathNameExt As String
    Dim sOutputFilePath As String
    Dim sOutput As String
    Dim lNameCount As LongPtr
    Dim rngCell As Range
    Dim sExt As String
    Dim lCopyCount As Long
    
    Set rngNames = Worksheets("Sheet2").Range("A1").CurrentRegion
    sOriginalFilepathNameExt = "C:\Users\philip.bornemeier\Documents\-- Excel Processing\MrE\Build Calendar.xlsb"
    sOutputFilePath = "C:\Users\philip.bornemeier\Documents\-- Excel Processing\MrE\1\"
    
    sOutputFilePath = FixPath(sOutputFilePath)
    
    If Dir(sOriginalFilepathNameExt, vbNormal) = vbNullString Then
        sOutput = sOutput & vbLf & "Source File: " & sOriginalFilepathNameExt & " does not exist"
    End If
    If Dir(sOriginalFilepathNameExt, vbDirectory) = vbNullString Then
        sOutput = sOutput & vbLf & "Output Path: " & sOutputFilePath & " does not exist"
    End If
    
    If Len(sOutput) > 0 Then
        sOutput = Mid(sOutput, 2)
        MsgBox "The following problem(s) exist: " & vbLf & vbLf & sOutput & vbLf & vbLf & _
            "Correct problem(s) and try again.", , "Problems Found"
        GoTo End_Sub
    End If
    
    sExt = Mid(sOriginalFilepathNameExt, InStrRev(sOriginalFilepathNameExt, "."))
    lNameCount = rngNames.CurrentRegion.Cells.Count
    
    'To be thorough there should be a section here to check for duplicate or blank cells, to make
    '  sure the entered name was a valid filename, to make sure the file did not already exist,
    '  but I will leave that for your enjoyment
    
    Select Case MsgBox("Ready to make " & lNameCount & " copies of the file?", vbYesNo, "Make Copies?")
    Case vbYes
        For Each rngCell In rngNames.Cells
            FileCopy sOriginalFilepathNameExt, sOutputFilePath & rngCell.Value & sExt
            lCopyCount = lCopyCount + 1
        Next
        MsgBox lCopyCount & " copies made.", , "Coping Completed"
    Case Else
        MsgBox "Copy Cancelled", , "User Cancelled Copy"
    End Select
    
End_Sub:
    
End Sub

Function FixPath(sPath) As String
    'Ensure that the sPath path ends in a single path separator
    '  and does not contain multiple sequential path separators

    Dim sPathSep As String
    Dim lX As Long
    
    sPathSep = Application.PathSeparator
    
    sPath = Trim(sPath)
    Do While Right(sPath, 1) = sPathSep
        sPath = Left(sPath, Len(sPath) - 1)
    Loop
    For lX = Len(sPath) - 1 To 2 Step -1
        If Mid(sPath, lX, 1) = sPathSep And Mid(sPath, lX + 1, 1) = sPathSep Then
            sPath = Left(sPath, lX - 1) & Mid(sPath, lX + 1)
        End If
    Next
    sPath = sPath & sPathSep
    FixPath = sPath
    
End Function

 

[AAW425]

Thank you! When I run it, it is giving me an error "Run-time error '70': Permission Denied". This is happening right after it asks how many copies I want to make. Do you know how I could work around this?

 

[pbornemeier]

I assume the code is stopping with this line highlighted in yellow:

FileCopy sOriginalFilepathNameExt, sOutputFilePath & rngCell.Value & sExt

Error 70 on that line would occur ...
If the file you are copying is open or
If a file in the target directory exists with the same name as the target name and is already open

If the error was not on that line let me know.

I revised the code a bit and added a check to validate proposed filenames:

Option Explicit

Sub FileCopier()

    Dim rngNames As Range
    Dim sOriginalFilepathNameExt As String
    Dim sOutputFilePath As String
    Dim sOutput As String
    Dim lNameCount As LongPtr
    Dim rngCell As Range
    Dim sExt As String
    Dim lCopyCount As Long
    Dim lBadnameCount As Long
    Dim sTestFileNameExt As String
    
    Dim iFreeFile As Integer
    
    Set rngNames = Worksheets("Sheet1").Range("A1").CurrentRegion
    lNameCount = rngNames.CurrentRegion.Cells.Count

    sOriginalFilepathNameExt = "C:\Users\philip.bornemeier\Documents\-- Excel Processing\MrE\Build Calendar.xlsb"
    sExt = Mid(sOriginalFilepathNameExt, InStrRev(sOriginalFilepathNameExt, "."))
    sTestFileNameExt = "xyzzyTemp" & sExt

    sOutputFilePath = "C:\Users\philip.bornemeier\Documents\-- Excel Processing\MrE\1\"
    
    sOutputFilePath = FixPath(sOutputFilePath)
    
    'Check for missing source file
    If Dir(sOriginalFilepathNameExt, vbNormal) = vbNullString Then
        sOutput = sOutput & vbLf & "Source File: " & sOriginalFilepathNameExt & " does not exist"
    End If
    
    'Check for missing output path
    If Dir(sOriginalFilepathNameExt, vbDirectory) = vbNullString Then
        sOutput = sOutput & vbLf & "Output Path: " & sOutputFilePath & " does not exist"
    End If
    
    'Create a dummy file for name testing
    iFreeFile = FreeFile
    Open ThisWorkbook.Path & "\" & sTestFileNameExt For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=iFreeFile]#iFreeFile[/URL] 
    Write [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , "Hello World", 234    ' Write comma-delimited data.
    Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=iFreeFile]#iFreeFile[/URL] 

    'validate proposed filenames by creating & deleting files with target names and source extension
    rngNames.Cells.Interior.Color = xlNone 'Clear Color from cells
    
    On Error Resume Next
    For Each rngCell In rngNames.Cells
        DoEvents
        FileCopy ThisWorkbook.Path & "" & sTestFileNameExt, ThisWorkbook.Path & "" & rngCell.Value & sExt
        DoEvents
        Kill ThisWorkbook.Path & "" & rngCell.Value & sExt
        DoEvents
        If Err.Number <> 0 Then
            rngCell.Interior.Color = rgbYellow
            lBadnameCount = lBadnameCount + 1
            Err.Clear
        End If
        Debug.Print
    Next
    Kill ThisWorkbook.Path & "" & sTestFileNameExt
    
    'Any bad names found?
    If lBadnameCount > 0 Then
        sOutput = sOutput & vbLf & "There " & IIf(lBadnameCount = 1, "is ", "are ") & lBadnameCount & " invalid filename" & IIf(lBadnameCount = 1, "", "s") & " listed.  " & _
        IIf(lBadnameCount = 1, "This cell has", "These cells have") & " been colored yellow and must be corrected before continuing."
    End If
    
    'Were any errors found
    If Len(sOutput) > 0 Then
        sOutput = Mid(sOutput, 2)
        MsgBox "The following problem(s) exist: " & vbLf & vbLf & sOutput & vbLf & vbLf & _
            "Correct problem(s) and try again.", , "Problem(s) Found"
        GoTo End_Sub
    End If
    
    'To be thorough there should be a section here to check for duplicate or blank cells, to make
    '  sure the entered name was a valid filename, to make sure the file did not already exist,
    '  but I will leave that for your enjoyment
    
    Select Case MsgBox("Ready to make " & lNameCount & " copies of the file?", vbYesNo, "Make Copies?")
    Case vbYes
        For Each rngCell In rngNames.Cells
            FileCopy sOriginalFilepathNameExt, sOutputFilePath & rngCell.Value & sExt
            lCopyCount = lCopyCount + 1
        Next
        MsgBox lCopyCount & " copies made.", , "Coping Completed"
    Case Else
        MsgBox "Copy Cancelled", , "User Cancelled Copy"
    End Select
    
End_Sub:
    
End Sub

Function FixPath(sPath) As String
    'Ensure that the sPath path ends in a single path separator
    '  and does not contain multiple sequential path separators

    Dim sPathSep As String
    Dim lX As Long
    
    sPathSep = Application.PathSeparator
    
    sPath = Trim(sPath)
    Do While Right(sPath, 1) = sPathSep
        sPath = Left(sPath, Len(sPath) - 1)
    Loop
    For lX = Len(sPath) - 1 To 2 Step -1
        If Mid(sPath, lX, 1) = sPathSep And Mid(sPath, lX + 1, 1) = sPathSep Then
            sPath = Left(sPath, lX - 1) & Mid(sPath, lX + 1)
        End If
    Next
    sPath = sPath & sPathSep
    FixPath = sPath
    
End Function