create multiple copies of this workbook

[ajm]

has anybody got a ready made macro to make multiple copies of this workbook, using the names in column A (or anywhere) as the filename?

 

[Trebor76]

Hi ajm,

Run the following macro on the tab where the data is, assumed to be from cell A1 - change as required. If you're using Excel 2007 also change the extension accoringly:

Sub Macro1()

Dim rngCell As Range

    For Each rngCell In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

        ActiveWorkbook.SaveCopyAs rngCell.Value & ".xls"

    Next

End Sub

HTH

Robert

 

[ajm]

thanks Robert.

i am trying to adapt the code slightly to reference another workbook. this other workbook is the template that i wish to copy. not knowing at all what i am doing, i tried:

Private Sub CommandButton1_Click()
'///create workbooks
    Dim rngCell As Range
    'Define the application input box question
    ValToll = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
    If ValToll = False Then Aborted = True: Exit Sub

    Application.EnableEvents = False
    
        For Each rngCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

            ValTool.SaveCopyAs rngCell.Value & ".xls"

        Next

End Sub

it errors out when i try to pass the variable to the savecopyas.

any ideas how to fix it?

 

[Trebor76]

Hi ajm,

If you want to copy the template from a particular location into another user selected directory and call the copy(ies) based on the cell reference(s) on the active sheet, the following macro and udf (they must be placed in separate modules) will do the job:

Macro:

Sub ajm()

Dim strSourceFile, strMsg, strDirLocation, strCopyName As String
Dim objFSO As Object

strSourceFile = "C:\Template.xls" 'Template location

strMsg = "Please select a directory to copy the template into."
strDirLocation = GetDirectory(strMsg)
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
        For Each rngCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
        
            strCopyName = rngCell.Value & ".xls"
            objFSO.CopyFile strSourceFile, strDirLocation & "\" & strCopyName, overwritexisting = True

        Next
End Sub

udf:
(Refer http://www.j-walk.com/SS/excel/tips/tip29.htm for more info on the following udf)

Option Explicit
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
 
'   Root folder = Desktop
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the "Browse for Folder" dialog box
    x = SHBrowseForFolder(bInfo)
    
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

HTH

Robert

PS - Go the Blues!!!

 

[ajm]

thanks trebor. notice, i do not use your name the right way around. why not?? well, anyone south of the border is obviously backwards. Go the roons!!!

 

[Trebor76]

Oh well, there's always next year