create multiple files using save as with list as title

[dbrubaker]

Ok, so this is my first post since I normally just use the vast knowledge that has been dispersed on previous threads, but this one is more than a little stretch for me.

I have a template .jpg file that I would like copy multiple times and name each file according to a value found in a excel list and I am looking for a macro that could do that for me. In other words, I would like to open the file and save as A1, then save as A2, then save as A3, etc.

The closest thing that I have found is the following thread that works to open the template, but I can't figure out if I can save as and close it using the same macro.

http://www.excelforum.com/excel-prog...ith-macro.html

Thanks,
Daryl

[tigeravatar]

Daryl,

Welcome to the forum!
Give ths a try:

Sub tgr()
    
    Const strPicPath As String = "C:\Test\Pic.jpg"  'The full path the to the image file
    Const strFldrPath As String = "C:\Test"         'The folder path where the templates will be saved
    
    Dim arrSaveName As Variant
    Dim oPic As Object
    Dim NameIndex As Long
    Dim lPicWidth As Long
    Dim lPicHeight As Long
    
    arrSaveName = Sheets(1).Range("A1", Sheets(1).Cells(Rows.Count, "A").End(xlUp)).Value
    If Not IsArray(arrSaveName) Then Exit Sub
    Set oPic = LoadPicture(strPicPath)
    lPicWidth = Round(oPic.Width / 26.4588, 0)
    lPicHeight = Round(oPic.Height / 26.4588, 0)
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo CleanExit
    
    For NameIndex = 1 To UBound(arrSaveName, 1)
        Sheets.Add.Move
        With ActiveWorkbook
            .Sheets(1).Shapes.AddPicture strPicPath, msoFalse, msoTrue, 0, 0, lPicWidth, lPicHeight
            .Sheets(1).Name = arrSaveName(NameIndex, 1)
            .SaveAs strFldrPath & "\" & arrSaveName(NameIndex, 1) & ".xls", xlNormal
            .Close False
        End With
    Next NameIndex
    
CleanExit:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    If Err Then
        MsgBox Err.Description, , Err.Number
        Err.Clear
    End If
    
    Erase arrSaveName
    Set oPic = Nothing
    
End Sub

[dbrubaker]

Thanks tigeravatar,

That is almost perfect. The script worked, but I would actually like to save the new images as images (.jpg) instead of spreadsheet. What do I need to change to get that to happen?

Daryl

[tigeravatar]

Daryl,

Since you're just copying the image files instead of putting the images in workbooks and then saving the workbooks, the code gets much simpler. Give this a try:

Sub tgr()
    
    Const strSourcePath As String = "C:\Test\Pic.jpg"
    Const strDestFolder As String = "C:\Test\Subfolder1"
    
    Dim arrSaveName As Variant
    Dim NameIndex As Long
    Dim strExt As String
    
    strExt = Mid(strSourcePath, InStrRev(strSourcePath, "."))
    arrSaveName = Sheets(1).Range("A1", Sheets(1).Cells(Rows.Count, "A").End(xlUp)).Value
    If Not IsArray(arrSaveName) Then Exit Sub
    
    For NameIndex = 1 To UBound(arrSaveName, 1)
        FileCopy strSourcePath, strDestFolder & "\" & arrSaveName(NameIndex, 1) & strExt
    Next NameIndex
    
End Sub

[dbrubaker]

Tigeravatar,

Worked like a charm and saved me a ton of time. Thanks so much.

Daryl

[dbrubaker]

Tigeravatar,

So, I ran into a wall. I ran your macro script and it worked fine, in fact, it worked too well. I changed a bunch of files before I was ready to. So we reverted back to a backup version of the destination folder and since then I have not been able to get the macro to work. In fact I can't get either of your scripts to work now when both worked before. They don't give me an error or anything, so it seems like they are working, but nothing happens.

Do you have any idea what might be causing this? Or at least point me in a direction of something to try?

Thanks,

Daryl

[tigeravatar]

Daryl,

Both scripts assume that the list of names is in Sheet1 column A, and there is more than 1 name listed. If that is not the case, the script exits itself because it found no data. That's the only thing I can think of that would cause that kind of behaviour. You might also check to make sure the initial folder paths and file names are correct in the code after your restore.

If you do have the list of names in the 1st sheet column A and there is more than one name listed, I'd have to see a sample workbook that is experiencing the issue. When I test the code, it still runs fine for me.

[dbrubaker]

Tigeravatar,

Wow, totally did not even think about that. I was indeed trying to run the script with one entry. As soon as I put in two entries, it worked fine.

Thanks again,

Daryl