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
#1
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
Antwortento top
#2
kann wirklich keiner helfen?
Antwortento top
#3
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
Gruß Stefan
Win 7 / Office 2007
[-] Folgende(r) 1 Benutzer sagt Danke an Steffl für diesen Beitrag:
  • Pirat2015
Antwortento top
#4
Hallo Steffl,

ich bekomme folgende fehler:

"Variable nicht definiert"
Code:
' CREATE EMAIL OBJECT.
 Set objEmail = objOutlook.CreateItem(olMailItem)

olMailItem = wird Markiert
Antwortento top
#5
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
gruß
Marco
Antwortento top
#6
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?
Antwortento top
#7
Hallo,

poste den vollständigen Code.
Gruß Stefan
Win 7 / Office 2007
Antwortento top
#8
ich habe doch am Anfang den gesamten code geschrieben
Antwortento top
#9
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
Gruß Stefan
Win 7 / Office 2007
Antwortento top
#10
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
Antwortento top


Gehe zu:


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