Speichern unter ( ohne Makros)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
mal ein VBA-Rundumschlag
Option Explicit
'by Ramses

Sub SaveSingleWorksheet()
'Kopiert das aktive Worksheet
ActiveSheet.Copy
Call DelModule
Call DelUForms
Call DelEvent
ActiveWorkbook.SaveAs Range("A1") & ".xls", xlNormal
End Sub

Sub DelModule()
'Löscht Module:
With ActiveWorkbook
    For n = .VBProject.VBComponents.Count To 1 Step -1
        If .VBProject.VBComponents(n).Type = 1 Then
            .VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
        End If
    Next
End With
End Sub

Sub DelUForms()
'Löscht Userforms:
With ActiveWorkbook
    For n = .VBProject.VBComponents.Count To 1 Step -1
        If .VBProject.VBComponents(n).Type = 3 Then
            .VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
        End If
    Next
End With
End Sub

Sub DelEvent()
'Löscht Ereignisprozeduren:
With ActiveWorkbook
    For n = .VBProject.VBComponents.Count To 1 Step -1
        For i = 1 To .VBProject.VBComponents(n).CodeModule.CountOfLines
        If ThisWorkbook.VBProject.VBComponents(n).Type <> 1 And .VBProject.VBComponents(n).Type <> 3 Then _
                .VBProject.VBComponents(n).CodeModule.DeleteLines 1
        Next
    Next
End With
End Sub

Gruss Rainer

Hallo
probiers mal

Option Explicit

Sub SaveSingleSheet()
    Dim i As Integer, y As Integer, totFiles As Integer, Qe As Integer
    Dim Sind As Long
    Dim wks As Worksheet
    Dim gefFile As String
    Dim Suchbegriff As String, Suchpfad As String
    Dim oldStatus As Variant
    'Neue Funktion erst ab Office XP verwendbar
    'bzw. auch unter 2000 wenn ein Verweis auf die Office 10 Library
    'gesetzt werden kann.
    'Öffnet einen Dialog indem der Pfad elegant wie im normalen
    'Datei-Dialog gewählt werden kann.
    Dim Suchdialog As FileDialog
    Set Suchdialog = Application.FileDialog(msoFileDialogFolderPicker)
    If Application.Version < 10 Then
        Qe = MsgBox("Diese Datei bzw. dieser Suchdialog ist erst ab EXCEL XP möglich!", vbCritical + vbOKOnly, "Tut mir leid...")
        Exit Sub
    End If
    oldStatus = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    'Hier wird der neue FolderPickerDialog aufgerufen
    With Suchdialog
        .Title = "Bitte wählen Sie ein Verzeichnis aus"
        'Environ(25) ermittelt den Aktuellen Userpfad
        .InitialFileName = Environ(25) & "\Eigene Dateien\"
        .ButtonName = "Auswahl übernehmen"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Sie haben keine Auswahl getroffen", vbInformation
            Set Suchdialog = Nothing
            Exit Sub
        Else
            For Sind = 1 To .SelectedItems.Count
                Suchpfad = Suchpfad & .SelectedItems(Sind)
            Next Sind
        End If
    End With
    ActiveSheet.Copy
    Call DelModule
    Call DelUForms
    Call DelEvent
    ActiveWorkbook.SaveAs Suchpfad & "\" & Range("A1") & ".xls", xlNormal
End Sub

Sub DelModule()
    'Löscht Module:
    Dim n As Integer
    With ActiveWorkbook
        For n = .VBProject.VBComponents.Count To 1 Step -1
            If .VBProject.VBComponents(n).Type = 1 Then
                .VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
            End If
        Next
    End With
End Sub

Sub DelUForms()
    'Löscht Userforms:
    Dim n As Integer
    With ActiveWorkbook
        For n = .VBProject.VBComponents.Count To 1 Step -1
            If .VBProject.VBComponents(n).Type = 3 Then
                .VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
            End If
        Next
    End With
End Sub

Sub DelEvent()
    'Löscht Ereignisprozeduren:
    Dim n As Integer
    With ActiveWorkbook
        For n = .VBProject.VBComponents.Count To 1 Step -1
            For i = 1 To .VBProject.VBComponents(n).CodeModule.CountOfLines
            If .VBProject.VBComponents(n).Type <> 1 And .VBProject.VBComponents(n).Type <> 3 Then _
                .VBProject.VBComponents(n).CodeModule.DeleteLines 1
            Next
        Next
    End With
End Sub
Gruss Rainer

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Speichern unter ( ohne Makros)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread