Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 12:23:24
19.04.2024 11:45:34
Anzeige
Archiv - Navigation
1152to1156
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Änderung

VBA Änderung
Tom

Hallo,
ich habe mir eine Vorlagendatei gebastelt. In dieser Datei rufe ich nachfolgendes Makro (gefunden im www) auf.
Das entsprechende Tabellenblatt wird wie gewünscht gespeichert. Nur wenn ich die gespeicherte Datei öffne erfolgt eine Meldung, dass das Format von dem in der Dateierweiterung abweicht.
Prinzipiell habe ich verschiedene Tabellenblätter. Auf jedem dieser Tabellen gibt es Buttons die mit Makros hinterlegt. Auch hohle ich über Sverweis-Funktion verschiedene Bilder in die jeweilige Tabelle.
Nun möchte ich das die aktive Tabelle (aus meiner Vorlagendatei) unter einem eingebaren Namen (Speichern unter) mit den entsprechenden Bildern jedoch ohne die Makros als "normale" Exceldatei gespeichert.
Viele Grüße Tom
Sub SpeicherMirsAlsNeueMappe()
Dim wksA As Worksheet
Dim wbkNeu As Workbook, wbkAlt As Workbook
Dim vntPathAndFile As Variant
Dim I As Integer
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
'Aktuelles Blatt merken
Set wksA = ActiveSheet
vntPathAndFile = Application.GetSaveAsFilename( _
InitialFileName:= _
fs.GetBaseName(ActiveWorkbook.Name) & " - " & _
wksA.Name & " -" & _
Format(Now, " yyyy-mm-dd") & ".xls", _
FileFilter:="Excel Files(*.xls), *.xls", _
Title:="Speichern als")
If Not vntPathAndFile = False Then
'Aktuelle Mappe merken
Set wbkAlt = ActiveWorkbook
'Neue Mappe erzeugen
Set wbkNeu = Workbooks.Add
'Das Blatt an erste Stelle kopieren
wksA.Copy wbkNeu.Sheets(1)
'Alle anderen (leeren) Bl?tter l?schen
Application.DisplayAlerts = False
For I = wbkNeu.Sheets.Count To 2 Step -1
wbkNeu.Sheets(I).Delete
Next
Application.DisplayAlerts = True
'Neue Datei speichern
wbkNeu.SaveAs vntPathAndFile
'Neue Datei schlie?en
wbkNeu.Close
End If
End Sub

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
MS und seine Versionen
02.05.2010 10:21:45
Tino
Hallo,
ab xl2007 gibt es unterschiedliche Formate die man berücksichtigen muss.
Versuche es mal mit dieser Version.
Sub SpeicherMirsAlsNeueMappe()
Dim wksA As Worksheet
Dim wbkNeu As Workbook, wbkAlt As Workbook
Dim vntPathAndFile As Variant
Dim I As Integer
Dim sExt$, intFormat
Dim fs As Object

Set fs = CreateObject("Scripting.FileSystemObject")

'Aktuelles Blatt merken 
Set wksA = ActiveSheet

With ActiveWorkbook
    sExt$ = Right$(.Name, Len(.Name) - InStrRev(.Name, ".") + 1)
    
    If InStr(sExt$, ".") = 0 Then
        If Val(Application.Version) < 12 Then
            sExt$ = ".xls"
        Else
            sExt$ = ".xlsm"
        End If
    End If
    
    vntPathAndFile = Application.GetSaveAsFilename( _
    InitialFileName:= _
        fs.GetBaseName(.Name) & " - " & _
        wksA.Name & " -" & _
        Format(Now, " yyyy-mm-dd") & sExt$, _
        FileFilter:="Excel Files(*" & sExt$ & "), *" & sExt$, _
        Title:="Speichern als")
End With

sExt$ = Right$(vntPathAndFile, Len(vntPathAndFile) - InStrRev(vntPathAndFile, ".") + 1)

If Not vntPathAndFile = False Then
    'Aktuelle Mappe merken 
    Set wbkAlt = ActiveWorkbook
    'Neue Mappe erzeugen 
    Set wbkNeu = Workbooks.Add
    'Das Blatt an erste Stelle kopieren 
    wksA.Copy wbkNeu.Sheets(1)
    'Alle anderen (leeren) Bl?tter l?schen 
    Application.DisplayAlerts = False
    For I = wbkNeu.Sheets.Count To 2 Step -1
    wbkNeu.Sheets(I).Delete
    Next
    Application.DisplayAlerts = True
    
    'Neue Datei speichern 
    Select Case LCase(sExt$)
        Case ".xls": intFormat = xlExcel8
        Case ".xlsm": intFormat = xlOpenXMLWorkbookMacroEnabled
        Case ".xlsx": intFormat = xlOpenXMLWorkbook
        Case ".xlsm": intFormat = xlExcel12
    End Select
    
    wbkNeu.SaveAs vntPathAndFile, intFormat
        'Neue Datei schlie?en 
    wbkNeu.Close
End If
End Sub
Gruß Tino
Anzeige
AW: MS und seine Versionen
02.05.2010 14:19:46
Tom
Hi,
diese Version funktioniert bei mir fehlerfrei. Dankeschön.
Gruß Tom
bis Version 11
02.05.2010 10:38:07
Tino
Hallo,
wenn Du mit bis zu Version 11 arbeitest, musst Du die Konstanten durch den Wert ersetzen
weil diese Versionen diese Konstanten nicht kennt.
    'Neue Datei speichern
If Val(Application.Version) 
Gruß Tino
Korrektur ...
02.05.2010 10:42:50
Tino
Hallo,
mach aus der Zeile
Case ".xlsm": intFormat = 50 'xlExcel12
noch diese
Case ".xlsb": intFormat = 50 'xlExcel12
jetzt sollte es passen.
Gruß Tino
Anzeige
AW: Korrektur ...
02.05.2010 14:17:35
Tom
Hallo Tino,
danke für deine Mühe
Leider funktioniert dein Code bei mir weder mit den Zahlen noch mit dem text es wird immer nachfolgende Zeile bemängelt.
Nun habe ich davon zu wenig wissen um damit etwas anfangen zu können.
wbkNeu.SaveAs vntPathAndFile, intFormat
Danke dir trotzdem. Danke.
Gruß Tom

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige