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.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & XBlatt.Name, 51
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
Hallo,
also es funktioniert alles und theoretisch so wie ich es will aber es gibt eine Sache:
Beim Ausführen des Codes kopiert sich die "Master Datei" also Datei in welche das gesamte abläuft.
Das ist nicht sehr gut, da die Datei eine art Lagerübersicht ist und ständig neu gefüllt wird, was am ende zu sehr großen Datei führt.
Vielleicht zu Verständnis: Ich selektiere einzelne Zeilen
über suchdialog und mit diesen CODE:
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
Erzeuge ich eine neue ExcelTabelle in welcher nur die selektierten Zeilen mit spezifischen Zellen stehen.
Es wäre viel bequemer, das nicht die "Master Datei" kopiert und gespeichert und gesendet wird sondern diese neu Erzeugte ExcelTabelle mit selektierten Suchergebnissen.
Ginge das?
Hallo,
ersetze diese Codezeile
durch diese
Sehr gut, Vielen Dank --> Letze frage, was muss ich Code ändern damit die neue Erzeugte Excel nicht mir angezeigt wird sondern nur per email gesendet wird?
Dann spare ich mir die zeit um diese zu schlissen:)
und zweitens, wie kann ich erreichen, das in der email Signatur mit angezeigt wird
Habe doch noch was vergessen --> wie kriege ich den eMail text in dieser Form
"Sehr geehrte Damen und Herren,
Anbei die email mit Anhang direkt aus der Excel.
Bitte bearbeiten.
Vielen Dank"
Vielen Dank
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
wks2.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & XBlatt.Name, 51
Set wkbVersand = ActiveWorkbook
strName = wkbVersand.FullName
wkbVersand.Close
'alternativ, bitte mal testen
' wkb2.SaveAs ThisWorkbook.Path & "\" & 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 = "bsp@email.com"
.Subject = "Email direkt aus Excel mit Anhang"
.Body = "Sehr geehrte Damen und Herren," & vbCrLf & vbCrLf & _
"Anbei die email mit Anhang direkt aus der Excel." & vbCrLf & "Bitte bearbeiten"
' .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
Steffl,
die neue erzeugte Excel speichert sich dort wo der "Master file" abgelegt ist, das ist nicht gut, weil "Master file" auf SharePoint liegt und dort kann nicht jeder speichern.
Ich möchte das neu erzeugte Excel sich lokal auf C speichert und dann versendet wird.
Was muss ich abändern?
Hallo,
anstatt so
Code:
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & XBlatt.Name, 51
versuche es so
Code:
ActiveWorkbook.SaveAs "C:\" & XBlatt.Name, 51
Die neu erzeugte Excel, schlisst sich nicht automatisch und die Signature fehlt,
Wenn wir die zwei dinge noch hinkriegen dann wäre ich sehr dankbar
Hallo,
meine Kommentierung hattest Du wohl nicht gesehen?
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
' wks2.Copy
'
' ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & XBlatt.Name, 51
' Set wkbVersand = ActiveWorkbook
'
' strName = wkbVersand.FullName
' wkbVersand.Close
'alternativ, bitte mal testen
wkb2.SaveAs "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 = "bsp@email.com"
.Subject = "Email direkt aus Excel mit Anhang"
.Body = "Sehr geehrte Damen und Herren," & vbCrLf & vbCrLf & _
"Anbei die email mit Anhang direkt aus der Excel." & vbCrLf & "Bitte bearbeiten"
.GetInspector
' .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
es funktioniert soweit alles gut und die zu versende Excel Tabelle schlisst sicht.
Jetzt habe ich ein problem, die ursprüngliche excel Tabelle welche ich mit diesen Code erzeuge schlisst sich nicht.
Hier ist der Komplete CODE welche ich jetzt benutze.
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
ErrHandler:
End Sub
ich muss irgendwie das Program dazu bringen, die Uhrsprungsdatei zu schlissen