Laufzeitfehler 1004
20.04.2017 16:54:42
Dennis
ich bekomme bei Ausführung leider einen Laufzeitfehler, den ich leider nichtbeseitigt bekomme.
Es erscheinen folgende Fehlermeldungen:
Das ist der Code:
Sub MA09Mail()
Dim Nachricht As Object, OutApp As Object
Dim AWS As String
Application.ScreenUpdating = False 'Bildschirmaktualisierug ausschalten
Application.DisplayAlerts = False 'Fehlermeldungen ausschalten
Titel = Sheets(1).Range("A24").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").Range("A2:AF5").Copy Sheets(Titel).Range("A1")
Sheets("Januar").Range("A24:AF25").Copy Sheets(Titel).Range("A5")
'Februar Kopieren
Sheets("Februar").Range("B2:AF5").Copy Sheets(Titel).Range("B8")
Sheets("Februar").Range("A24:AF25").Copy Sheets(Titel).Range("A12")
'März Kopieren
Sheets("März").Range("B2:AF5").Copy Sheets(Titel).Range("B15")
Sheets("März").Range("A24:AF25").Copy Sheets(Titel).Range("A19")
'April Kopieren
Sheets("April").Range("B2:AF5").Copy Sheets(Titel).Range("B22")
Sheets("April").Range("A24:AF25").Copy Sheets(Titel).Range("A26")
'Mai Kopieren
Sheets("Mai").Range("B2:AF5").Copy Sheets(Titel).Range("B29")
Sheets("Mai").Range("A24:AF25").Copy Sheets(Titel).Range("A33")
'Juni Kopieren
Sheets("Juni").Range("B2:AF5").Copy Sheets(Titel).Range("B36")
Sheets("Juni").Range("A24:AF25").Copy Sheets(Titel).Range("A40")
'Juli Kopieren
Sheets("Juli").Range("B2:AF5").Copy Sheets(Titel).Range("B43")
Sheets("Juli").Range("A24:AF25").Copy Sheets(Titel).Range("A47")
'August Kopieren
Sheets("August").Range("B2:AF5").Copy Sheets(Titel).Range("B50")
Sheets("August").Range("A24:AF25").Copy Sheets(Titel).Range("A54")
'September Kopieren
Sheets("September").Range("B2:AF5").Copy Sheets(Titel).Range("B57")
Sheets("September").Range("A24:AF25").Copy Sheets(Titel).Range("A61")
'Oktober Kopieren
Sheets("Oktober").Range("B2:AF5").Copy Sheets(Titel).Range("B64")
Sheets("Oktober").Range("A24:AF25").Copy Sheets(Titel).Range("A68")
'November Kopieren
Sheets("November").Range("B2:AF5").Copy Sheets(Titel).Range("B71")
Sheets("November").Range("A24:AF25").Copy Sheets(Titel).Range("A75")
'Dezember Kopieren
Sheets("Dezember").Range("B2:AF5").Copy Sheets(Titel).Range("B78")
Sheets("Dezember").Range("A24:AF25").Copy Sheets(Titel).Range("A82")
'Zellen Anpassen
Columns("A").AutoFit
Columns("B:AG").ColumnWidth = 3
Cells.RowHeight = 16.5
'Selection.RowHeight = 16.5
Range("A1").Select
'Druckbereich festlegen
Sheets(Titel).PageSetup.PrintArea = "$A$1:$AF$83"
'Drucker eigenschaften
'Application.PrintCommunication = False
With ActiveSheet.PageSetup
'.LeftHeader = ""
.CenterHeader = "Planung " & Titel
'.RightHeader = ""
.LeftHeader = "&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 = xlPrintSheetEnd
' .PrintQuality = 1200
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA3
'.FirstPageNumber = xlAutomatic
'.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.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
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, Jochen Plapp." ' & "" & 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
Kann mir jemand weiterhelfen?
Vielen Dank im Voraus,
Dennis.
PS: Falls jemand noch optimierungen für den Code hat gerne sagen, ich baue mit der Hand am Arm... ;-)