Macro button which export range of worksheet to a new file and save as xls or pdf

[PitMax]

Hi, there,

Can anyone help me to figure out the macro commands which:

1. Copy the specific range of sheet into a new workbook;

2. Copied workbook will contain the cell values and format only not the strings or formulas.

3. "Save as", so the user can choose the directory and the name of the file when saving it.

4. Macro button shouldn't be copied to new file.

I'm sure it's not so difficult, but I couldn't program it or get it done through the "Record Macro" command.

Thank you very much in advance for help.

 

[John_w]

I don't know what you mean by 'strings'. Try this macro, changing the range to save in the new workbook as required.

Public Sub Save_Range_Values_Formats_In_New_Workbook()
        
    Dim saveRange As Range
    Dim newWorkbook As Workbook
    Dim destCell As Range
    Dim saveAsFile As Variant
    
    'Define range to save in new workbook
    
    Set saveRange = ActiveSheet.Range("A20:E39")
    
    saveRange.Copy
    Set newWorkbook = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
    Set destCell = newWorkbook.Worksheets(1).Range("A1")
    
    With destCell
        .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
        'Use Format Painter to copy and paste row heights
        
        saveRange.EntireRow.Copy
        .Resize(saveRange.Rows.Count).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
        destCell.Select
        .Worksheet.Name = saveRange.Worksheet.Name
    End With
    
    Application.CutCopyMode = False
    
    saveAsFile = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path, FileFilter:="Excel Workbook (*.xlsx), *.xlsx")
  
    If saveAsFile <> False Then
        'Error trap in case Excel displays warning 'File xxxx already exists. Do you want to replace it?' with Yes, No, Cancel buttons
        'and user clicks No or Cancel
        On Error Resume Next
        newWorkbook.SaveAs Filename:=saveAsFile, FileFormat:=xlOpenXMLWorkbook
        On Error GoTo 0
        If newWorkbook.Saved Then
            newWorkbook.Close False
            MsgBox "New workbook saved as " & saveAsFile, vbInformation
        Else
            newWorkbook.Close False
            MsgBox "New workbook not saved", vbExclamation
        End If
    Else
        newWorkbook.Close False
        MsgBox "New workbook not saved", vbExclamation
    End If
 
End Sub

 

[PitMax]

Hi,
Fantastic!
Thank you very much. It works!

Nevertheless, In one of the sheets, I need to solve the problem of merged cells, as below error appears.

It looks, that the copied file keeps all formating as original, so it is OK, but the error appears.

Is there any possible way to add commands that:
- copy the objects (pictures) - In original sheet there is a company logo which is not moved to copied file.
- copy information about printing area

Kind Regards,

PitMax


PS.
Strings - I call formulas that refers to other sheets and files.

 

[John_w]

This handles merged cells and:

- copy the objects (pictures) - In original sheet there is a company logo which is not moved to copied file.
- copy information about printing area

Public Sub Save_Range_Values_Formats_In_New_Workbook()
        
    Dim saveRange As Range
    Dim newWorkbook As Workbook
    Dim destCell As Range
    Dim saveAsFile As Variant
    
    'Define range to save in new workbook
    
    Set saveRange = ActiveSheet.Range("A20:G39")
    
    saveRange.Copy
    Set newWorkbook = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
    Set destCell = newWorkbook.Worksheets(1).Range("A1")
    
    With destCell
        .Select
        'Paste range including formats, merged cells and pictures
        .Worksheet.Paste
        'Apply column widths
        .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'Change cells to values
        .Resize(saveRange.Rows.Count, saveRange.Columns.Count).Value = saveRange.Value
        'Use Format Painter to copy and paste row heights
        saveRange.EntireRow.Copy
        .Resize(saveRange.Rows.Count).EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        destCell.Select
        'Copy print area
        .Worksheet.PageSetup.PrintArea = .Resize(saveRange.Rows.Count, saveRange.Columns.Count).Address
        'Name new sheet same as saveRange sheet
        .Worksheet.Name = saveRange.Worksheet.Name
    End With
    
    Application.CutCopyMode = False
    
    saveAsFile = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path, FileFilter:="Excel Workbook (*.xlsx), *.xlsx")
  
    If saveAsFile <> False Then
        'Error trap in case Excel displays warning 'File xxxx already exists. Do you want to replace it?' with Yes, No, Cancel buttons
        'and user clicks No or Cancel
        On Error Resume Next
        newWorkbook.SaveAs Filename:=saveAsFile, FileFormat:=xlOpenXMLWorkbook
        On Error GoTo 0
        If newWorkbook.Saved Then
            newWorkbook.Close False
            MsgBox "New workbook saved as " & saveAsFile, vbInformation
        Else
            newWorkbook.Close False
            MsgBox "New workbook not saved", vbExclamation
        End If
    
    Else
        newWorkbook.Close False
        MsgBox "New workbook not saved", vbExclamation
    End If
 
End Sub

 

[PitMax]

You are a Star!!!
It works perfectly!!
Thank you Very Much.