Code läuft unter F8 aber nicht bei F5
12.01.2015 09:54:21
Johannes
bei den folgenden Code habe ich das Problem, dass er im Einzelschrittmodus mit [F8] einwandfrei durchläuft, aber mit [F5] immer bei ActiveWorkbook.SaveAs Filename:= ... hängenbleibt, oder ohne im günstigen Falle nur als "Bestellung.xls" gespeichert wird.
Hat jemand eine Idee was ich besser machen kann?
Für Eure Hilfe schon jetzt vielen Dank.
Viele Grüße
Johannes
Hinweis: name@domain.de wurde hier nur "Platzhalter" verwendet ;-)
Code:
Sub mailen1()
Dim Dat As Variant
Dat = Date
Dim PNr As Variant
PNr = Range("M3").Value2
Dim BNr As Variant
BNr = Range("K3").Value2
'Kopie speichern unter Name & Datum
Sheets("mail").Select
Sheets("mail").Copy
ChDir "C:\Daten\Bestellungen"
ActiveWorkbook.SaveAs Filename:="C:\Daten\Bestellungen\Bestellung " & PNr & BNr & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Formel in Werte wandeln
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B2").Select
Application.CutCopyMode = False
'Blattname ändern
Sheets("mail").Select
Sheets("mail").Name = Dat
Range("B25").Select
'PNr Eintrag entfernen
Range("M3").Select
Selection.ClearContents
'startet outlook
Dim Nachricht As Object, OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim AWS As String
AWS = "C:\Daten Müller\Bestellungen\Bestellung " & PNr & BNr & ".xls"
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = "name@domain.de"
.To = "name@domain.de"
.CC = "name@domain.de"
.BCC = "name@domain.de"
.Subject = "Bestellung " & Date & " " & Time
.attachments.Add AWS
.Body = "Guten Tag," & vbCrLf & _
" " & vbCrLf & _
"in der Anlage erhalten Sie die Datei mit " & vbCrLf & _
"unserer Bestellung von heute, " & Dat & " ." & vbCrLf & _
" " & vbCrLf & _
"Mit freundlichen Grüßen" & vbCrLf & _
" " & vbCrLf & _
"Vorname Name"
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
'oder erst ansehen
.Display
End With
Set OutApp = Nothing
Set Nachricht = Nothing
Windows("Bestell-Liste Ersatzteile-Material.xls").Activate
Sheets("Bestellung").Select
End Sub