Hilfe beim zusammenführen von 2 Codes

[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.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

[Pirat2015]

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?

[Steffl]

Hallo,

ersetze diese Codezeile

Code:

XBlatt.Copy

durch diese

Code:

wks2.Copy

[Pirat2015]

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

[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
  
  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

[Pirat2015]

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?

[Steffl]

Hallo,

anstatt so

Code:

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & XBlatt.Name, 51

versuche es so

Code:

ActiveWorkbook.SaveAs  "C:\" & XBlatt.Name, 51

[Pirat2015]

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

[Steffl]

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

[Pirat2015]

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