VBA Excel to PDF soll alle Zellen in richtiger Breite darstellen

[Georgeous]

Hallo liebe Community,

ich hoffe ihr könnt mir helfen und ich hoffe ich bin im richtigen Thread..

Habe folgendes Problem: Ich habe eine VBA geschrieben die das aktuelle Tabellenblatt in PDF convertiert und als Mail Anhang versendet werden soll. Nur werden die Spalten nicht in der korrekten breite dargestellt. Die Zellen überlappen sich und ich komm nicht darauf wie ich das in der VBA anpassen kann damit das passt.

Könnt Ihr mir hier eventuell weiterhelfen?

In den Anlagen seht ihr die Excel sowie das (nicht zufriedenstellende Ergebnis)

Anbei die VBA:

Code:

Private Sub PDF_Erstellen()
   
    Dim TempFile, PDFFile As String
    Dim tmpJahr As String
    Dim tmpMonat As String
    Dim tmpNach As String
    Dim tmpVor As String
    Dim OutApp As Object
    Dim Nachricht
   
    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")
    Set Nachricht = OutApp.CreateItem(0)
    tmpJahr = Range("C3").Text
    tmpMonat = Range("C5").Text
    tmpNach = Range("D6").Text
    tmpVor = Range("G6").Text
    Range("A1:K50").Select
    Selection.Copy
    TempFile = ThisWorkbook.Path & "\TempAZNW" & ".xlsx"
    Workbooks.Add
    Range("A1:K50").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1:K50").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").Select
    ActiveWorkbook.Date1904 = True
    ActiveWorkbook.SaveAs TempFile, xlWorkbookDefault
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.70866141732284)
        .RightMargin = Application.InchesToPoints(0.708661417322835)
        .TopMargin = Application.InchesToPoints(0.78740157480315)
        .BottomMargin = Application.InchesToPoints(0.78740157480315)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    PDFFile = ThisWorkbook.Path & "\Sammelabrechnung" & tmpJahr & "_" & tmpMonat & "_" & tmpNach & "_" & tmpVor & ".pdf"
    'Ermittlung von Monat, Jahr, Name, Vorname für Dateinamen
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    ActiveWorkbook.Close False
    Kill TempFile
    With Nachricht
        .Subject = "Vorgesetztenmeldung " & ActiveSheet.Name & " " & tmpJahr & " - " & tmpNach & ", " & tmpVor
        .Attachments.Add PDFFile
        .to = ""
        .Display
        '.Send
    End With
    Set OutApp = Nothing
    Set Nachricht = Nothing
    'Auf Outlook warten. Ist nicht schnell genug :-))
    Application.Wait (Now + TimeValue("0:00:04"))
    Kill PDFFile
    Range("D12").Select
   
    Application.ScreenUpdating = True

End Sub

   

[snb]

Bitte, verwende Code Tags

[Klaus-Dieter]

Hallo,

warum machst du das nicht einfach mit der Standardfunktion von Excel?

[LCohen]

PDF-Ersteller sind unterschiedlich gut. 

Der von MS kostenlos bei neuem Office mitgegebene erzeugt zwar leider große Dateien (Minimum 440 KB oder so), aber dafür stimmt die Ausgabe eigentlich immer.

Genereller Tipp für alle Ausgaben (also Screen, PDF, Print): Kalkuliere nicht zu knauserig mit Abständen, Rändern und so. Dann bleibt Dein Dokument allverwendbar.