These pages are no longer updated and are only available for archive purposes.

Click here to visit the pages with updated information.

Export to a new workbook/worksheet

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

Document last updated 2006-07-11 20:10:04