Hilfe beim zusammenführen von 2 Codes

[Steffl]

Hallo,

teste mal

Code:

Private Sub prcPira_Click()
'Materialanforderung per email

Const olMailItem As Long = 0
Dim objOutlook As Object
Dim objEmail As Object
Dim wkbVersand As Workbook
Dim strName As String

Dim iCounter, xCounter As Long
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Add(1)
Set wks2 = wkb2.Sheets(1)
     wkb1.Activate
With ThisWorkbook.Sheets(1).Cells(13, 54)
If .Value = Date Then
     .Offset(, 1) = .Offset(, 1) + 1
Else
     .Value = Date
     .Offset(, 1) = 1
End If
End With
For iCounter = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(iCounter) And xOpt = 1 Or xOpt = 2 Then
    Set XBlatt = Sheets(ListBox1.List(iCounter, 0))
    XZeile = Range(ListBox1.List(iCounter, 1)).Row
    XBlatt.Cells(XZeile, 54).Value = Date
    xCounter = xCounter + 1
    XBlatt.Range("D" & XZeile & ",F" & XZeile & ",H" & XZeile & ",K" & XZeile & ",N" & XZeile & ",R" & XZeile & ",S" & XZeile & ",T" & XZeile & ",AR" & XZeile & ",AS" & XZeile & ",AT" & XZeile & ",AU" & XZeile & ",AV" & XZeile & ",AY" & XZeile & "").Copy wks2.Cells(xCounter, 1)
'andere Spalte nehmen!
     XBlatt.Cells(XZeile, 55).Value = ThisWorkbook.Sheets(1).Cells(13, 55).Value
End If
Next iCounter

wks2.Copy

'ActiveWorkbook.SaveAs "C:\" & XBlatt.Name, 51

   wkb2.SaveAs ThisWorkbook.Path & "C:\" & XBlatt.Name, 51
   Set wkbVersand = wkb2
   strName = wkbVersand.FullName
   wkbVersand.Close
  
  On Error GoTo ErrHandler

' SET Outlook APPLICATION OBJECT.
Set objOutlook = CreateObject("Outlook.Application")

' CREATE EMAIL OBJECT.
Set objEmail = objOutlook.CreateItem(olMailItem)

With objEmail
     .To = "alexander.kokscharow@durr.com"
    .Subject = "Material Request from Site Manager"
     .Body = "Dear Site Logistics Manager," & vbCrLf & vbCrLf & _
     "Please find attached the material request, with like to ask you to prepper for me soon." & vbCrLf & "As soon as Material ready to pick up please contact me." & vbCrLf & "Many Thank "
'        .Display
'        .Attachments.Add ("C:\neue erzeugte excel.xls")
      .Attachments.Add strName
     .Send
End With

Kill strName
' CLEAR.
Set objEmail = Nothing:    Set objOutlook = Nothing
Application.OnTime Now + TimeValue, "prcSchliessen"
ErrHandler:
End Sub

Sub prcSchliessen()
   Application.DisplayAlerts False
   Application.Quit
End Sub

Kopier aber bitte das zweite Makro auch mit.

[snb]

PHP-Code:

ActiveSheet.Range(Replace(Replace(Replace("D~F~H~K~N~R~:T~AR~:AV~AY~#", "~:", "5:"), "~", "5,"), ",#", "")).Select 


[Pirat2015]

Es kommt ein Fehler

Argument ist nicht optional

[Steffl]

Hallo,

sorry, da habe ich einen Fehler gemacht

Code:

Application.OnTime Now + TimeValue("0:0:1"), "prcSchliessen"

[Pirat2015]

Bei der zweien Makro wird ein Fehler angezeigt:

"Unzulässiger Verwendung einer Eigenschaft"

Code:

Sub prcSchliessen()
  Application.DisplayAlerts False <-- Hier kommt der fehler
  Application.Quit
End Sub

[Steffl]

Hallo,

Code:

Sub prcSchliessen()
  Application.DisplayAlerts = False
  Application.Quit
End Sub

[Pirat2015]

Also es ändert sich nichts --> wie gesagt

Beim Ausführen des Makros passiert folgendes:

1. Neue Exceltabelle mit selektierten Daten wird geöffnet
2. Neue Exceltabelle wird kopiere und am bestimmten Speicher ort hinterlegt, die Kopierte Datei (mit neue Name) wird geschlossen
3. Outlook wird gestartet und die kopierte excel wird als Anhang reingezogen
4. Email wird versendet mit den Daten
5. Die neu erzeugte Excel (Punkt1) wird aber nicht geschlossen sondern bleib offen und muss Manuel geschlossen werden <-- Da möchte ich nicht Manuel machen sondern 
automatisch

Neue Ablauf wäre wie folgt:

1. Neue Exceltabelle mit selektierten Daten wird geöffnet

2. Neue Exceltabelle wird kopiere und am bestimmten Speicher ort hinterlegt, die Kopierte Datei (mit neue Name) wird geschlossen

3. Neue Exceltabelle (Punk1) wird automatisch geschlossen ohne speichern

4. Outlook wird gestartet und die kopierte excel wird als Anhang reingezogen

5. Email wird versendet mit den Daten

[Steffl]

Hallo,

Code:

Private Sub prcPira_Click()
'Materialanforderung per email

Const olMailItem As Long = 0
Dim objOutlook As Object
Dim objEmail As Object
Dim wkbVersand As Workbook
Dim strName As String

Dim iCounter, xCounter As Long
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Add(1)
Set wks2 = wkb2.Sheets(1)
     wkb1.Activate
With ThisWorkbook.Sheets(1).Cells(13, 54)
If .Value = Date Then
     .Offset(, 1) = .Offset(, 1) + 1
Else
     .Value = Date
     .Offset(, 1) = 1
End If
End With
For iCounter = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(iCounter) And xOpt = 1 Or xOpt = 2 Then
    Set XBlatt = Sheets(ListBox1.List(iCounter, 0))
    XZeile = Range(ListBox1.List(iCounter, 1)).Row
    XBlatt.Cells(XZeile, 54).Value = Date
    xCounter = xCounter + 1
    XBlatt.Range("D" & XZeile & ",F" & XZeile & ",H" & XZeile & ",K" & XZeile & ",N" & XZeile & ",R" & XZeile & ",S" & XZeile & ",T" & XZeile & ",AR" & XZeile & ",AS" & XZeile & ",AT" & XZeile & ",AU" & XZeile & ",AV" & XZeile & ",AY" & XZeile & "").Copy wks2.Cells(xCounter, 1)
'andere Spalte nehmen!
     XBlatt.Cells(XZeile, 55).Value = ThisWorkbook.Sheets(1).Cells(13, 55).Value
End If
Next iCounter


'ActiveWorkbook.SaveAs "C:\" & XBlatt.Name, 51

   wkb2.SaveAs ThisWorkbook.Path & "C:\" & XBlatt.Name, 51
'   Set wkbVersand = wkb2
   strName = wkb2.FullName
   wkb2.Close
  
  On Error GoTo ErrHandler

' SET Outlook APPLICATION OBJECT.
Set objOutlook = CreateObject("Outlook.Application")

' CREATE EMAIL OBJECT.
Set objEmail = objOutlook.CreateItem(olMailItem)

With objEmail
     .To = "alexander.kokscharow@durr.com"
    .Subject = "Material Request from Site Manager"
     .Body = "Dear Site Logistics Manager," & vbCrLf & vbCrLf & _
     "Please find attached the material request, with like to ask you to prepper for me soon." & vbCrLf & "As soon as Material ready to pick up please contact me." & vbCrLf & "Many Thank "
'        .Display
'        .Attachments.Add ("C:\neue erzeugte excel.xls")
      .Attachments.Add strName
     .Send
End With

Kill strName
' CLEAR.
Set objEmail = Nothing:    Set objOutlook = Nothing
Application.OnTime Now + TimeValue("0:0:1"), "prcSchliessen"
ErrHandler:
End Sub