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.
Clever-Excel-Forum › Office-Anwendungen › Excel v
Hilfe beim zusammenführen von 2 Codes

Thema geschlossen 
Baumstrukturmodus
Hilfe beim zusammenführen von 2 Codes
Steffl Offline
Excelanwender
Registriert seit: 11.04.2014
Version(en): Office 2007
#11
08.11.2019, 10:58
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
Gruß Stefan
Win 10 / Office 2016
Suchen
Antworten Top
Pirat2015 Offline
Benutzer
ThreadStarter

Registriert seit: 03.10.2018
Version(en): 2016
#12
08.11.2019, 15:40
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?
Suchen
Antworten Top
Steffl Offline
Excelanwender
Registriert seit: 11.04.2014
Version(en): Office 2007
#13
08.11.2019, 17:12
Hallo,

ersetze diese Codezeile

Code:
XBlatt.Copy

durch diese

Code:
wks2.Copy
Gruß Stefan
Win 10 / Office 2016
[-] Folgende(r) 1 Nutzer sagt Danke an Steffl für diesen Beitrag:
  • Pirat2015
Suchen
Antworten Top
Pirat2015 Offline
Benutzer
ThreadStarter

Registriert seit: 03.10.2018
Version(en): 2016
#14
08.11.2019, 18:55 (Dieser Beitrag wurde zuletzt bearbeitet: 08.11.2019, 18:55 von 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
Suchen
Antworten Top
Steffl Offline
Excelanwender
Registriert seit: 11.04.2014
Version(en): Office 2007
#15
08.11.2019, 20:05
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
Gruß Stefan
Win 10 / Office 2016
[-] Folgende(r) 1 Nutzer sagt Danke an Steffl für diesen Beitrag:
  • Pirat2015
Suchen
Antworten Top
Pirat2015 Offline
Benutzer
ThreadStarter

Registriert seit: 03.10.2018
Version(en): 2016
#16
08.11.2019, 20:07
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?
Suchen
Antworten Top
Steffl Offline
Excelanwender
Registriert seit: 11.04.2014
Version(en): Office 2007
#17
08.11.2019, 20:21
Hallo,

anstatt so

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

versuche es so

Code:
ActiveWorkbook.SaveAs  "C:\" & XBlatt.Name, 51
Gruß Stefan
Win 10 / Office 2016
Suchen
Antworten Top
Pirat2015 Offline
Benutzer
ThreadStarter

Registriert seit: 03.10.2018
Version(en): 2016
#18
08.11.2019, 20:24
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
Suchen
Antworten Top
Steffl Offline
Excelanwender
Registriert seit: 11.04.2014
Version(en): Office 2007
#19
08.11.2019, 20:40
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
Gruß Stefan
Win 10 / Office 2016
Suchen
Antworten Top
Pirat2015 Offline
Benutzer
ThreadStarter

Registriert seit: 03.10.2018
Version(en): 2016
#20
08.11.2019, 23:27
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
Suchen
Antworten Top
Thema geschlossen 


Gehe zu:


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