Eksporterer data til et nytt regneark/arbeidsbok

Denne makroen eksporterer verdier eller formler og diagrammer fra et regnearkområde til et nytt regneark/arbeidsbok:

Sub ExportRangeAsWB(SourceRange As Range, TargetFile As String, SaveValuesOnly As Boolean)
' Eksporterer data i regnearkområdet SourceRange til
' arbeidsboken TargetFile i et standard arbeidsbokformat
' Eksempler:
' 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
    ' valider input
    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 & _
                " finnes fra før, flytt, slett eller gi filen et nytt navn før du forsøker igjen.", _
                vbInformation, "Export range to textfile"
            Exit Sub
        End If
    End If
    
    ' eksporter data
    Application.ScreenUpdating = False
    Set TargetWB = NewWorkbook(1) ' oppretter en ny arbeidsbok med ett regneark
    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
                    ' hele diagrammet er innenfor eksportområdet
                    co.Copy ' kopier diagramobjektet
                    Range(co.TopLeftCell.Address).PasteSpecial xlPasteAll ' lim inn diagramobjektet
                End If
            End If
            
        Next co
        Set co = Nothing
        
        tr = tr + SourceRange.Areas(A).Rows.Count ' angi neste målrad
    Next A
    
    ' rydd opp
    Range("A1").Select
    TargetWB.SaveAs TargetFile
    'If TargetWB.Saved Then TargetWB.Close False ' lukk den nye arbeidsboken
    Set TargetWB = Nothing
    Application.ScreenUpdating = True
End Sub

Private Function NewWorkbook(wsCount As Integer) As Workbook
' oppretter en ny arbeidsbok med wsCount (1 til 255) antall regneark
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

Dokumentet er sist oppdatert 2006-07-11 20:11:56 Utskriftsvennlig versjon