Anstatt einer .pdf Datei eine .xlsx Datei machen

Question

Hallo guten Tag möchte fragen ist es möglich den folgenden code so zu schreiben sodass nicht eine .pdf Datei entsteht, sondern eine .xlsx Datei.  Es gibt eine With Tabelle5, Tabelle6 und Tabelle7. Danke

Sub Pdf_Ausgabe_Reservierung() 'pdf ausgabe
    
Dim Spalte As Integer
Dim SpalteEnd As Integer
With Tabelle5           'Tabelle angeben z:B.Tabelle5
SpalteEnd = .UsedRange.Columns.Count

For Spalte = 7 To 40
If .Cells(42, Spalte).Value <= 0.1 Then 'kontrolliert wird in Zeile 42
.Columns(Spalte).Hidden = True
Else
.Columns(Spalte).Hidden = False
End If
Next Spalte

End With
    Dim strFileName As String, strPath As String, strFolder As String, varFile, blnOpen As Boolean
    strFolder = MsgBox("Soll die neue PDF-Datei im gleichen Ordner wie die Excel-Mappe gespeichert werden?", vbYesNoCancel, "PDF speichern")
    If strFolder = vbNo Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ActiveWorkbook.Path
            .Title = "Verzeichnisauswahl"
            If .Show = -1 Then strPath = .SelectedItems(1)
        End With
    ElseIf strFolder = vbYes Then
        strPath = ActiveWorkbook.Path
    ElseIf strFolder = vbCancel Then
        Exit Sub
    End If
    strFileName = strPath & "\" & ActiveSheet.Range("AQ8").Value & ".pdf"
    Do Until Dir(strFileName, vbNormal) = ""
        varFile = Application.InputBox("Eine Datei mit diesem Namen existiert bereits. Bitte einen neuen Namen eingeben.", , "\" & ActiveSheet.Range("AQ8").Value & ".pdf")
        If varFile = False Then Exit Sub
        strFileName = strPath & "\" & varFile
    Loop
    blnOpen = IIf(MsgBox("Soll die Neue PDF-Datei nach dem Speichern geöffnet werden?", vbYesNo, "PDF öffnen") = vbYes, True, False)
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=blnOpen
    
    Range("o3").Select

End Sub

Answer 1

Schreib xlTypeXPS anstatt xlTypePDF

Und an den anderen Stellen auch entsprechend 

Answer 2

Hallo es wird eine .XPS Datei erzeugt und nicht eine .xlsx zudem kann ich die .XPS Datei nicht öffnen. Danke

Answer 3

Ersetze

blnOpen = IIf(MsgBox("Soll die Neue PDF-Datei nach dem Speichern geöffnet werden?", vbYesNo, "PDF öffnen") = vbYes, True, False)
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=blnOpen

durch

ActiveSheet.Copy

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strFileName, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True

Mr. K.

Answer 4

Hallo Mr. K. es müssten noch 4 Steuerelemente (Schaltknöpfe) vor der speicherung entfernt werden. Ich habe Tabelle5, Tabelle6 und Tabelle7 wie oben beschrieben, muß ich den code in jeder Tabelle einfügen oder geht es auch anders. Danke

Answer 5

Hi Jelena,

das mit dem Entfernen der Schaltknöpfe hatten wir doch schon im anderen Thread.

For Each shp In ActiveSheet.Shapes
  shp.Delete
Next shp

Hier geht es darum die Datei nicht als PDF sondern als Xlsx zu speichern. Wie bereits erwähnt kommt der Code nicht in ein Tabellenmodul sondern in ein Standardmodul. Das kannst du über Menü Einfügen -> Modul hinzufügen.

Willst du die drei Tabellen in der selben xlsx-Datei speichern oder für jede eine einzelne Datei erstellen?

Mr. K.

Answer 6

Hallo Mr. K. an welcher stelle muß der code eingefügt werden.

For Each shp In ActiveSheet.Shapes
  shp.Delete
Next shp

Die drei Tabellen werden in eine einzelne Datei gespeichert. Danke

Answer 7

Die drei Zeilen kannst du an beliebiger Stelle einfügen. z.B. direkt vor der ActiveWorkbook.SaveAs Zeile

Um deinen Code für alle drei Tabellen auszuführen und sie jeweils in einzelne Dateien zu splitten mach eine Schleife drumrum:

  For Each tbl In Sheets(Array("Tabelle5", "Tabelle6", "Tabelle7"))
    'dein Code
  Next tbl

Ersetze außerdem in deinem Code das Wort ActiveSheet oder Tabelle5 durch tbl.

Gruß Mr. K.

Answer 8

Hallo Mr. K. leider komme ich mit den zwei letzten code nicht weiter, deswegen bitte den code richtigstellen. Vielen Dank

Option Explicit
Sub xlsx_ausgabe() 'xlsx ausgabe
Dim Spalte As Integer
Dim SpalteEnd As Integer
With Tabelle5           'Tabelle angeben z:B.Tabelle5
SpalteEnd = .UsedRange.Columns.Count

For Spalte = 7 To 40
If .Cells(42, Spalte).Value <= 0.1 Then 'kontrolliert wird in Zeile 42
.Columns(Spalte).Hidden = True
Else
.Columns(Spalte).Hidden = False
End If
Next Spalte

End With
    
    Dim strFileName As String, strPath As String, strFolder As String, varFile, blnOpen As Boolean
    strFolder = MsgBox("Soll die neue xlsx-Datei im gleichen Ordner wie die Excel-Mappe gespeichert werden?", vbYesNoCancel, "xlsx speichern")
    If strFolder = vbNo Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ActiveWorkbook.Path
            .Title = "Verzeichnisauswahl"
            If .Show = -1 Then strPath = .SelectedItems(1)
        End With
    ElseIf strFolder = vbYes Then
        strPath = ActiveWorkbook.Path
    ElseIf strFolder = vbCancel Then
        Exit Sub
    End If
    strFileName = strPath & "\" & ActiveSheet.Range("AQ8").Value & ".xlsx"
    Do Until Dir(strFileName, vbNormal) = ""
        varFile = Application.InputBox("Eine Datei mit diesem Namen existiert bereits. Bitte einen neuen Namen eingeben.", , "\" & ActiveSheet.Range("AQ8").Value & ".xlsx")
        If varFile = False Then Exit Sub
        strFileName = strPath & "\" & varFile
    Loop
   
ActiveSheet.Copy

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strFileName, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
    
    'Werte eintragen und Rest löschen
    Range("G1:AN1,AO8:AY43,A43:AN43").Select
    Range("A43").Activate
    Selection.ClearContents
    Cells.Select
    Cells.FormatConditions.Delete
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Application.CutCopyMode = False
 
    Range("a11").Select

End Sub

Answer 9

ungetestet in etwa so:

Option Explicit
Sub xlsx_ausgabe() 'xlsx ausgabe
Dim Spalte As Integer, shp As Shape
Dim SpalteEnd As Integer, tbl As Worksheet




For Each tbl In Sheets(Array("Tabelle5", "Tabelle6", "Tabelle7"))



With tbl           'Tabelle angeben z:B.Tabelle5
SpalteEnd = .UsedRange.Columns.Count

For Spalte = 7 To 40
If .Cells(42, Spalte).Value <= 0.1 Then 'kontrolliert wird in Zeile 42
.Columns(Spalte).Hidden = True
Else
.Columns(Spalte).Hidden = False
End If
Next Spalte

End With
    
    Dim strFileName As String, strPath As String, strFolder As String, varFile, blnOpen As Boolean
    strFolder = MsgBox("Soll die neue xlsx-Datei im gleichen Ordner wie die Excel-Mappe gespeichert werden?", vbYesNoCancel, "xlsx speichern")
    If strFolder = vbNo Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ActiveWorkbook.Path
            .Title = "Verzeichnisauswahl"
            If .Show = -1 Then strPath = .SelectedItems(1)
        End With
    ElseIf strFolder = vbYes Then
        strPath = ActiveWorkbook.Path
    ElseIf strFolder = vbCancel Then
        Exit Sub
    End If
    strFileName = strPath & "\" & tbl.Range("AQ8").Value & ".xlsx"
    Do Until Dir(strFileName, vbNormal) = ""
        varFile = Application.InputBox("Eine Datei mit diesem Namen existiert bereits. Bitte einen neuen Namen eingeben.", , "\" & tbl.Range("AQ8").Value & ".xlsx")
        If varFile = False Then Exit Sub
        strFileName = strPath & "\" & varFile
    Loop
   
tbl.Copy

For Each shp In tbl.Shapes
  shp.Delete
Next shp

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strFileName, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
    tbl.Select
    'Werte eintragen und Rest löschen
    Range("G1:AN1,AO8:AY43,A43:AN43").Select
    Range("A43").Activate
    Selection.ClearContents
    Cells.Select
    Cells.FormatConditions.Delete
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Application.CutCopyMode = False
 
    Range("a11").Select

Next tbl

End Sub

Answer 10

Hallo habe die frühere Version gewählt, da kommt aber diese Fehlermeldung der Rest passt. Danke  https://supportnet.de/forum/?qa=blob&qa_blobid=14572835426396987241

For Each shp In ActiveSheet.Shapes
  shp.Delete
Next shp