10.12.2021, 13:14
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:
[attachment=41294]
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[attachment=41294]