Snasui Excel Forum

Code: Select all

Application.DisplayAlerts = False
Sheets("Data").Copy
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="Excel Files (*.xlsx), *.xlsx", _
        Title:="Select Folder and FileName to save")
ActiveWorkbook.SaveAs Filename:=myFile, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True

Code: Select all

Dim aName, myFile As Range
Dim fldr As FileDialog
Dim selectedFolder As String
Application.DisplayAlerts = False
Set aName = Sheets("Input").Range("e6:e8")
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .Show
        selectedFolder = .SelectedItems(1)
    End With
For Each myFile In aName
    Sheets("Data").Copy
    ActiveWorkbook.SaveAs Filename:=selectedFolder & "\" & myFile & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
Next myFile
Application.DisplayAlerts = True

Code: Select all

myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="Excel Files (*.xls), *.xls", _
        Title:="Select Folder and FileName to save")
ActiveWorkbook.SaveAs Filename:=myFile, FileFormat:=XlFileFormat.xlExcel12

Code: Select all

Private Sub CommandButton1_Click()
Worksheets("Data").Activate

'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")


'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for saving file
strFile = Sheets("Input").Range("E6").Value & "_" & Sheets("Input").Range("E7").Value & "_" & Sheets("Input").Range("E12").Value & ".xls"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="Excel Files (*.xls), *.xls", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    'wsA.ExportAsFixedFormat
    'Copy the ActiveSheet to new workbook
            For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
                    wsA.UsedRange.PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
   Next

    'confirmation message with file info
    MsgBox "Excel  file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create Excel file"
    Resume exitHandler

End Sub