Export to a new Workbook/Worksheet
2006-07-11 Import & Export 0 318
This macro exports the values or formulas and charts from a worksheet range to a new workbook/worksheet:
Sub ExportRangeAsWB(SourceRange As Range, TargetFile As String, SaveValuesOnly As Boolean) ' Exports the data in the range SourceRange to ' the workbook TargetFile in standard workbook format ' Examples: ' ExportRangeAsWB Range("A1:M25"), "C:\FolderName\TargetWB.xls", True ' ExportRangeAsWB Worksheets("Sheet2").Range("A1:M25"), "C:\FolderName\TargetWB.xls", True Dim r As Long, c As Integer, tr As Long Dim TargetWB As Workbook, A As Integer Dim co As ChartObject ' validate the input data if necessary If SourceRange Is Nothing Then Exit Sub If Len(Dir(TargetFile)) > 0 Then On Error Resume Next Kill TargetFile On Error GoTo 0 If Len(Dir(TargetFile)) > 0 Then MsgBox TargetFile & _ " already exists, rename, move or delete the file before you try again.", _ vbInformation, "Export range to textfile" Exit Sub End If End If ' perform export Application.ScreenUpdating = False Set TargetWB = NewWorkbook(1) ' creates a new workbook with one worksheet tr = 1 For A = 1 To SourceRange.Areas.Count SourceRange.Areas(A).Copy If SaveValuesOnly Then With Range("A" & tr) .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats End With Else Range("A" & tr).PasteSpecial xlPasteAll End If Application.CutCopyMode = False With SourceRange.Areas(A) ' set rowheights For r = 1 To .Rows.Count Rows(r).RowHeight = .Rows(r).RowHeight Next r ' set columnwidths For c = 1 To .Columns.Count Columns(c).ColumnWidth = .Columns(c).ColumnWidth Next c End With For Each co In SourceRange.Parent.ChartObjects ' Debug.Print co.TopLeftCell.Address, co.BottomRightCell.Address If Not Intersect(SourceRange.Areas(A), co.TopLeftCell) Is Nothing Then 'If Not Intersect(SourceRange.Areas(A), co.BottomRightCell) Is Nothing Then If Not Intersect(SourceRange.Areas(A), co.BottomRightCell.Offset(-1, -1)) Is Nothing Then ' the whole chart object is within the export range co.Copy ' copy the chart object Range(co.TopLeftCell.Address).PasteSpecial xlPasteAll ' paste the chart object End If End If Next co Set co = Nothing tr = tr + SourceRange.Areas(A).Rows.Count ' set the new target row Next A ' clean up Range("A1").Select TargetWB.SaveAs TargetFile 'If TargetWB.Saved Then TargetWB.Close False ' close the new workbook Set TargetWB = Nothing Application.ScreenUpdating = True End Sub Private Function NewWorkbook(wsCount As Integer) As Workbook ' creates a new workbook with wsCount (1 to 255) worksheets Dim OriginalWorksheetCount As Long Set NewWorkbook = Nothing If wsCount < 1 Or wsCount > 255 Then Exit Function OriginalWorksheetCount = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = wsCount Set NewWorkbook = Workbooks.Add Application.SheetsInNewWorkbook = OriginalWorksheetCount End Function