Hilfe beim zusammenführen von 2 Codes

[Pirat2015]

Hallo Zusammen,
Ich benötige eure Hilfe beim folgenden problem:

Mit folgenden Code, erzeuge ich eine neue Exceltabelle aus bestehende Exceltabelle.

Code:

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
End Sub

Ich möchte aber erreiche, das mit den Betätigung des Buttons nicht eine neue Excel erzeugt wird, sonder eine neue outlook (email) wird gesendet, Die Excel Datei soll als Anhang in der Email sein.

ich habe folgende Code für email erzeugen gefunden:

Code:

ub Schaltfläche1_Klicken()
   On Error GoTo ErrHandler
   
   ' SET Outlook APPLICATION OBJECT.
   Dim objOutlook As Object
   Set objOutlook = CreateObject("Outlook.Application")
   
   ' CREATE EMAIL OBJECT.
   Dim objEmail As Object
   Set objEmail = objOutlook.CreateItem(olMailItem)

   With objEmail
       .to = "bsp@email.com"
      .Subject = "Email direkt aus Excel mit Anhang"
       .Body = "Hallo ich bin die eMail aus excel"
'        .Display
'        .Attachments.Add ("C:\neue erzeugte excel.xls")
       .Send
   End With
   
   ' CLEAR.
   Set objEmail = Nothing:    Set objOutlook = Nothing
   
ErrHandler:

End Sub

Kann man diese Codes irgendwie Kombinieren?
 
Danke

[Pirat2015]

kann wirklich keiner helfen?

[Steffl]

Hallo,

dein Code ist etwas unvollständig ich konnte es daher auch nicht testen aber gemäß dieser Seite
https://www.online-excel.de/excel/singsel_vba.php?f=86
könnte es so gehen

Code:

Sub prcPirat()
  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
 
  Set wkbVersand = XBlatt.SaveAs(ThisWorkbook.Path & "\" & XBlatt.Name)
  strName = wkbVersand.FullName
 
  On Error GoTo ErrHandler
 
  ' SET Outlook APPLICATION OBJECT.
  Set objOutlook = CreateObject("Outlook.Application")
 
  ' CREATE EMAIL OBJECT.
  Set objEmail = objOutlook.CreateItem(olMailItem)

  With objEmail
      .to = "bsp@email.com"
     .Subject = "Email direkt aus Excel mit Anhang"
      .Body = "Hallo ich bin die eMail aus excel"
'        .Display
'        .Attachments.Add ("C:\neue erzeugte excel.xls")
       .Attachments.Add strName
      .Send
  End With
 
  Kill strName
  ' CLEAR.
  Set objEmail = Nothing:    Set objOutlook = Nothing
 
ErrHandler:
End Sub

[Pirat2015]

Hallo Steffl,

ich bekomme folgende fehler:

"Variable nicht definiert"

Code:

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

olMailItem = wird Markiert

[Mase]

Hi,

die Konstante olMailItem ist durch das LateBinding unbekannt.

Zwei Möglichkeiten:
a) ersetze olMailitem durch eine 0
b) schreibe nach der Zeile Option Explicit  bzw. oben im Modul

Code:

Const olMailItem as long = 0

Hinweis:
Onlinhilfe zur olItem-Type-Aufzählung

[Pirat2015]

jetzt ist der Fehler weg aber es passiert nicht wenn ich den button betätige

PS: habe die email Adresse abgeändert


und wenn ich "Sub prcPirat()" durch "Private Sub CommandButton4_Click()" ersetze dann wird die Funktion bis 

Code:

XBlatt.Cells(XZeile, 55).Value = ThisWorkbook.Sheets(1).Cells(13, 55).Value
  End If
  Next iCounter
 

 ausgeführt und ab hier 

Code:

et wkbVersand = XBlatt.SaveAs(ThisWorkbook.Path & "\" & XBlatt.Name)
 strName = wkbVersand.FullName
 
 On Error GoTo ErrHandler

wird ein Fehler angezeigt 

"Objekt erfordelich"
was ist hier falsch?

[Steffl]

Hallo,

poste den vollständigen Code.

[Pirat2015]

ich habe doch am Anfang den gesamten code geschrieben

[Steffl]

Hallo,

Code:

Sub prcPirat()
  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
  
  
  XBlatt.SaveAs (ThisWorkbook.Path & "\" & XBlatt.Name)
  Set wkbVersand = ActiveWorkbook
  
  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 = "bsp@email.com"
     .Subject = "Email direkt aus Excel mit Anhang"
      .Body = "Hallo ich bin die eMail aus excel"
'        .Display
'        .Attachments.Add ("C:\neue erzeugte excel.xls")
       .Attachments.Add strName
      .Send
  End With
  
  Kill strName
  ' CLEAR.
  Set objEmail = Nothing:    Set objOutlook = Nothing
  
ErrHandler:
End Sub

[Pirat2015]

Hallo Steffl
wenn ich den Code ausführe passiert folgendes:

Es wird eine neue Excel Tabelle erzeugt, ich denke das is dieser Code (denn ich ja schon vorher hatte)

Code:

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
End Sub

Jetzt mit deinen Code, wird auch die Datei in welche in Makro ausführe kopiert und geschlossen, die kopierte excel wird geöffnet und dann kommt
Laufzeit Fehler 424 - Objekt erforderlich

dieser Code wir gelb eangezeigt

Code:

Set wkbVersand = XBlatt.SaveAs(ThisWorkbook.Path & "\" & XBlatt.Name)

Ich möchte aber erreichen, das die neu Erzeugte excel welche ich mit diesen Code erstelle:

Code:

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
End Sub

Einfach auf C am besten auf den Display gespeichert wird, dann das outlook aufgeht und sich diese Datei als Anhang zieht und an die angegeben email versenden.
Die Datei in welche diese Aktionen ausgeführt werden soll nicht angetatstetwerden


geht das?

Vielen Dank