ich habe vor - und das funktioniert bei mir auch echt super, dass aus einer Excel-Datei eine neue Datei erstellt wird, diese dann als PDF in einer Mail in Outlook versandt wird.
Bei mir funktioniert die Datei wie gesagt super - bei meinem Kollegen erscheint leider ein Laufzeitfehler 1004 und das Debugging startet. Wenn ich dem Makro dann sage weiter zu laufen, läuft es jedoch problemlos durch, außer dass die Seiteneinstellungen verloren gehen.
Könnt Ihr mir helfen?
Der Debugger bleibt bei "Application.PrintCommunication = True" nach den seiteneigenschaften - hier bleibt das Scirpt hängen.
Sub MA01Mail()
Application.ScreenUpdating = False 'Bildschirmaktualisierug ausschalten
Application.DisplayAlerts = False 'Fehlermeldungen ausschalten
Titel = Sheets(1).Range("A8").Value
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) 'neues Blatt am Ende der _
Tabelle
Sheets(Worksheets.Count).Name = Titel
'Januar Kopieren
Application.CutCopyMode = False
Sheets("Januar").Select
Range("A2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Januar").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Februar Kopieren
Application.CutCopyMode = False
Sheets("Februar").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B8").Select
ActiveSheet.Paste
Sheets("Februar").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A12").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'März Kopieren
Application.CutCopyMode = False
Sheets("März").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B15").Select
ActiveSheet.Paste
Sheets("März").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A19").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'April Kopieren
Application.CutCopyMode = False
Sheets("April").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B22").Select
ActiveSheet.Paste
Sheets("April").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A26").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Mai Kopieren
Application.CutCopyMode = False
Sheets("Mai").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B29").Select
ActiveSheet.Paste
Sheets("Mai").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A33").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Juni Kopieren
Application.CutCopyMode = False
Sheets("Juni").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B36").Select
ActiveSheet.Paste
Sheets("Juni").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A40").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Juli Kopieren
Application.CutCopyMode = False
Sheets("Juli").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B43").Select
ActiveSheet.Paste
Sheets("Juli").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A47").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'August Kopieren
Application.CutCopyMode = False
Sheets("August").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B50").Select
ActiveSheet.Paste
Sheets("August").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A54").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'September Kopieren
Application.CutCopyMode = False
Sheets("September").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B57").Select
ActiveSheet.Paste
Sheets("September").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A61").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Oktober Kopieren
Application.CutCopyMode = False
Sheets("Oktober").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B64").Select
ActiveSheet.Paste
Sheets("Oktober").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A68").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'November Kopieren
Application.CutCopyMode = False
Sheets("November").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B71").Select
ActiveSheet.Paste
Sheets("November").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A75").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Dezember Kopieren
Application.CutCopyMode = False
Sheets("Dezember").Select
Range("B2:AF5").Select
Selection.Copy
Sheets(Titel).Select
Range("B78").Select
ActiveSheet.Paste
Sheets("Dezember").Select
Range("A8:AF9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Titel).Select
Range("A82").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Zellen Anpassen
Columns("A").Select
Selection.EntireColumn.AutoFit
Columns("B:AG").Select
Selection.ColumnWidth = 3
Cells.Select
Selection.RowHeight = 16.5
Application.CutCopyMode = False
Range("A1").Select
'Druckbereich festlegen
Sheets(Titel).Select
ActiveSheet.PageSetup.PrintArea = "$A$1:$AF$83"
'Drucker eigenschaften
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "Planung " & Titel
.RightHeader = ""
.LeftHeader = "&B&D"
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.78740157480315)
.RightMargin = Application.InchesToPoints(0.78740157480315)
.TopMargin = Application.InchesToPoints(0.984251968503937)
.BottomMargin = Application.InchesToPoints(0.984251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = True
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 1200
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = True
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.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
Application.PrintCommunication = True
'in pdf exportieren und an Ort speichern
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Temp\" & Format(Now, "YYYY") & "_Planung_" & Titel & "_" & Format(Now, " _
YYYYMMDD_hhmm") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
'Ab hier kommt das E-Mail Modul
'Range("a1:z44").Select
strFileName = "C:\Temp\" & Format(Now, "YYYY") & "_Planung_" & Titel & "_" & Format(Now, " _
YYYYMMDD_hhmm") & ".pdf"
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFileName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Dim Nachricht As Object, OutApp As Object
Dim AWS As String
Set OutApp = CreateObject("Outlook.Application")
AWS = strFileName
'InitializeOutlook = True
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Range("A82") 'Empfänger
'.Cc = Range("A82") 'CC-Empfänger
'.Bcc = "bbb@bb.de" 'Blindempfänger
.Subject = "[Aktuelle persönliche Planung] " ' & " - " & Range("C6") & " - " & Range("V6") _
'Betreff, Name, Datum
.Attachments.Add AWS
.HTMLBody = "Hallo, " & "" & "Im Dateianhang findest Du Deine aktuelle persönliche _
Planung." & "
" & "Viele Grüße." ' & "
" & Range("C6") 'Hier wird die HTML Mail erstellt
'.Display 'Hier wird die Mail nochmals angezeigt
.Send 'Direkt senden
End With
Set OutApp = Nothing
Set Nachricht = Nothing
Kill strFileName
'Hier Endet das E-Mail Modul
'Neuees Sheet (Tiel) löschen
Worksheets(Titel).Delete
'Bildschirmaktualisierug ausschalten
Application.ScreenUpdating = True
'Fehlermeldungen ausschalten
Application.DisplayAlerts = True
Beep 'Erfolgskontrolle, wenn Beep dann fertig durchgelaufen
End Sub