Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Hilfe beim zusammenführen von 2 Codes
#21
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.
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#22
PHP-Code:
ActiveSheet.Range(Replace(Replace(Replace("D~F~H~K~N~R~:T~AR~:AV~AY~#""~:""5:"), "~""5,"), ",#""")).Select 
Zum übersetzen von Excel Formeln:

http://dolf.trieschnigg.nl/excel/index.p...gids=en+de
Antworten Top
#23
Es kommt ein Fehler

Argument ist nicht optional
Antworten Top
#24
Hallo,

sorry, da habe ich einen Fehler gemacht

Code:
Application.OnTime Now + TimeValue("0:0:1"), "prcSchliessen"
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#25
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
Antworten Top
#26
Hallo,

Code:
Sub prcSchliessen()
  Application.DisplayAlerts = False
  Application.Quit
End Sub
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#27
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
Antworten Top
#28
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
Gruß Stefan
Win 10 / Office 2016
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste