Tabellenblätter speichern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub StartSpeichern() Dim NeueDatei As Workbook Dim myTab As Worksheet Dim ObjShell As Object Dim Desktop As String Set ObjShell = CreateObject("WScript.Shell") Desktop = ObjShell.SpecialFolders("Desktop") & "\" With Application .ScreenUpdating = False .DisplayAlerts = False For Each myTab In ThisWorkbook.Worksheets myTab.Copy Set NeueDatei = ActiveWorkbook NeueDatei.SaveAs Desktop & myTab.Name & ".xls" NeueDatei.Close False Next myTab .ScreenUpdating = True .DisplayAlerts = True End With End Sub

Sub StartSpeichern() Dim NeueDatei As Workbook Dim myTab As Worksheet Dim ObjShell As Object Dim Desktop As String Dim myArea Set ObjShell = CreateObject("WScript.Shell") Desktop = ObjShell.SpecialFolders("Desktop") & "\" With Application .ScreenUpdating = False .DisplayAlerts = False For Each myTab In ThisWorkbook.Windows(1).SelectedSheets myTab.Copy Set NeueDatei = ActiveWorkbook NeueDatei.ActiveSheet.UsedRange.Value = NeueDatei.ActiveSheet.UsedRange.Value NeueDatei.SaveAs Desktop & myTab.Name & ".xls" NeueDatei.Close False Next myTab .ScreenUpdating = True .DisplayAlerts = True End With End Sub

Hallo Zoran,
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub saveSheetsToFile()
    Dim objWS As Worksheet
    Dim strPath As String

    On Error GoTo ErrExit
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    strPath = BrowseForFolder("C:\")

    If strPath <> "Falsch" Then
        For Each objWS In ThisWorkbook.Windows(1).SelectedSheets
            objWS.Copy
            With ActiveWorkbook
                With Sheets(1)
                    .UsedRange = .UsedRange.Value
                End With
                .SaveAs strPath & "\" & objWS.Name & ".xls"
                .Close
            End With
        Next
    End If

    ErrExit:

    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description, Title:="Fehler"
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    'Function purpose: To Browser for a user selected folder.
    'If the "OpenAt" path is provided, open the browser at that directory
    'NOTE: If invalid, it will open at the Desktop level

    Dim ShellApp As Object

    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
        BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected. (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename. All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select

    Exit Function

    Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False

End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread