AW: Welche Excel-Version ?
11.08.2005 00:05:49
Ramses
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