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
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
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
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