Registriert seit: 03.10.2018
Version(en): 2016
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
Registriert seit: 03.10.2018
Version(en): 2016
kann wirklich keiner helfen?
Registriert seit: 11.04.2014
Version(en): Office 2007
01.11.2019, 17:18
(Dieser Beitrag wurde zuletzt bearbeitet: 01.11.2019, 17:19 von 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
Gruß Stefan
Win 10 / Office 2016
Folgende(r) 1 Nutzer sagt Danke an Steffl für diesen Beitrag:1 Nutzer sagt Danke an Steffl für diesen Beitrag 28
• Pirat2015
Registriert seit: 03.10.2018
Version(en): 2016
Hallo Steffl,
ich bekomme folgende fehler:
"Variable nicht definiert"
Code: ' CREATE EMAIL OBJECT.
Set objEmail = objOutlook.CreateItem(olMailItem)
olMailItem = wird Markiert
Registriert seit: 17.04.2019
Version(en): M$ 365 AfE v2009 / Office2013
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
Registriert seit: 03.10.2018
Version(en): 2016
04.11.2019, 22:51
(Dieser Beitrag wurde zuletzt bearbeitet: 04.11.2019, 22:51 von 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?
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo,
poste den vollständigen Code.
Gruß Stefan
Win 10 / Office 2016
Registriert seit: 03.10.2018
Version(en): 2016
ich habe doch am Anfang den gesamten code geschrieben
Registriert seit: 11.04.2014
Version(en): Office 2007
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 10 / Office 2016
Registriert seit: 03.10.2018
Version(en): 2016
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
|