Hallo liebe Community,
vll. könnt ihr mir weiterhelfen, ich möchte dass durch einen Klick auf einen Button alle eingegeben Daten in die gleiche Zeile gespeichert werden.
Irgendetwas mache ich falsch. Ich möchte auch den Fehler verhindern, wenn der vorherige User Daten ausgelassen hat, dass ausschließlich die neue Zeile befüllt wird und nichts in den Zeilen verrutscht.
Hierzu mein code.
Private Sub BeinaheunfallVerteilen_Click()
Worksheets("Beinaheunfall").Range("E3").Value = Me.ComboBox1.Value 'Werk
Worksheets("Beinaheunfall").Range("A5") = TextBoxBeinaheunfallVorname 'Vorname
Worksheets("Beinaheunfall").Range("E5") = TextBoxBeinaheunfallNachname 'Nachname
Worksheets("Beinaheunfall").Range("A7") = TextBoxBeinaheunfallMaschine 'Maschine
Worksheets("Beinaheunfall").Range("E7") = TextBoxBeinaheunfallAbteilung 'Abteilung
Worksheets("Beinaheunfall").Range("A10") = TextBoxBeinaheunfallUnfallhergang 'Unfallhergang
Worksheets("Beinaheunfälle").Cells(Cells(Rows.Count, "A").End(xlUp).Row + 1, "A").Value = TextBoxBeinaheUnfallDatum 'erste freie Zelle in Spalte A "Datum"
Worksheets("Beinaheunfälle").Cells(Cells(Rows.Count, "B").End(xlUp).Row + 1, "B").Value = ComboBox1 'erste freie Zelle in Spalte B "Werk"
Worksheets("Beinaheunfälle").Cells(Cells(Rows.Count, "C").End(xlUp).Row + 1, "C").Value = TextBoxBeinaheunfallVorname 'erste freie Zelle in Spalte C "Vorname"
Worksheets("Beinaheunfälle").Cells(Cells(Rows.Count, "D").End(xlUp).Row + 1, "D").Value = TextBoxBeinaheunfallNachname 'erste freie Zelle in Spalte D "Nachname"
Worksheets("Beinaheunfälle").Cells(Cells(Rows.Count, "E").End(xlUp).Row + 1, "E").Value = TextBoxBeinaheunfallMaschine 'erste freie Zelle in Spalte E "Maschine"
Worksheets("Beinaheunfälle").Cells(Cells(Rows.Count, "F").End(xlUp).Row + 1, "F").Value = TextBoxBeinaheunfallAbteilung 'erste freie Zelle in Spalte F "Abteilung"
Worksheets("Beinaheunfälle").Cells(Cells(Rows.Count, "G").End(xlUp).Row + 1, "G").Value = TextBoxBeinaheunfallUnfallhergang 'erste freie Zelle in Spalte G "Unfallhergang"
ChDir "C:\Temp\"
Worksheets("Beinaheunfall").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Temp\Beinaheunfall.pdf"
' ############################################################
' Die Variablen für Empfänger und Anhang sind richtig zu belegen
' ############################################################
Dim sText As String, sEmpfang As String, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject As Object
Dim rtitem As Object, sKopie As String
Dim AttachMe As Object, DerAnhang As Object
Dim user As String, server As String
Dim mailfile As String, sBlindKopie As String
Dim vAn As Variant, vCopy As Variant
Dim vBlind As Variant, sAnhang As String
On Error GoTo Fehler
sText = "Diese eMail wurde automatisch generiert und dient der Informationspflicht des SGA-Managementbeauftragten an die Zentrale." & vbCrLf & "Bei Fragen wenden Sie sich bitte an den Absender."
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
sEmpfang = "christoph.friedrich@scherdel.com" ' Einträge durch " ; " getrennt
sBetrifft = "Beinaheunfall" ' die Betreffzeile
sKopie = "" ' Einträge durch " ; " getrennt
sBlindKopie = "" ' Einträge durch " ; " getrennt
vAn = Split(sEmpfang, " ; ") ' Empfänger Array
sAnhang = "C:\Temp\Beinaheunfall.pdf" ' Muss natürlich richtig gesetzt werden
If Len(sKopie) > 0 Then vCopy = Split(sKopie, " ; ") 'cc Array
If Len(sBlindKopie) > 0 Then vBlind = Split(sBlindKopie, " ; ") 'bcc Array
Set session = CreateObject("notes.notessession") ' Notes muss gestartet sein
user = session.UserName
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set db = session.getdatabase(server, mailfile)
Set doc = db.createdocument()
doc.Form = "Memo"
doc.SendTo = vAn ' an array
If Len(sKopie) > 0 Then doc.copyto = vCopy 'cc Array
If Len(sBlindKopie) > 0 Then doc.blindcopyto = vBlind 'bcc Array
doc.Subject = sBetrifft ' die Betreffzeile
Set rtitem = doc.CREATERICHTEXTITEM("body")
Call rtitem.APPENDTEXT(sText)
doc.SAVEMESSAGEONSEND = True
doc.PostedDate = Now
' *******************************************
If sAnhang <> "" Then
Set AttachMe = doc.CREATERICHTEXTITEM("Attachment")
Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", sAnhang, "Attachment")
End If
'Tabellenblattinhalt löschen
Worksheets("Beinaheunfall").Range("A3:D3,E3:H3,A7:D7,E7:H7,A10:H44").ClearContents
Call doc.Send(False)
Aufraeumen:
On Error Resume Next
Set rtitem = Nothing
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set db = Nothing
Set doc = Nothing
Set session = Nothing
Kill "C:\Temp\Beinaheunfall.pdf"
'#################################
'#### Beinaheunfall schließen ####
'#################################
Unload UserformBeinaheunfall
Exit Sub
Fehler:
Resume Aufraeumen
End Sub
Private Sub UserForm_Activate()
Me.TextBoxBeinaheUnfallDatum.Text = Worksheets("Beinaheunfall").Range("A3").Value
'Worksheets("Beinaheunfälle").Range("A2") = TextBoxBeinaheUnfallDatum
End Sub
Vielen Dank im Voraus.
Lg Chris
|