VBA Zellwert übertragen wenn

Hallo liebe Könner!
Ich habe eine Datei erstellt, mit der ich Mitarbeiter in Pflichtschulungen einsetzen möchte:
https://www.herber.de/bbs/user/140371.xlsm
Die jeweils offenen Pflichtschulungen werden als Kürzel (offene ABK) erfasst. Über ein Drop-Down-Menü wird automatisch eine E-Mail an den Mitarbeiter erstellt, sobald eine entsprechende Schulung gewählt wurde.
Nun möchte ich gerne, dass die entsprechende Ziffer aus dem Bereich "Offene ABK" gelöscht wird und unter "Erledigte ABK" eingefügt wird, sobald unter "Einsatz Pflichtschulung" die entsprechende Schulung gewählt wurde. Bei mehreren offenen Pflichtschulungen soll es dann so sein, dass nur die entsprechende Ziffer, nicht aber der ganze Zelleninhalt gelöscht wird, da ja ggf. mehrere Schulungen offen sind.
Beispiel:
Darth Vader hat noch die Schulungen 123 offen, ich setze ihn in 2 ein, dann soll bei den erledigten die ABK 2 stehen und unter den offenen noch 13.
Ist das irgendwie machbar? Ich komme leider nicht weiter :(
Schon mal vielen Dank für die Hilfe!!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Select Case Target.Value Case "Arbeitsschutz" lngColumn = 1 Application.EnableEvents = False Cells(Target.Row, 4) = 1 Cells(Target.Row, 5) = Replace(Cells(Target.Row, 5), 1, "") Application.EnableEvents = True Case "Datenschutz" lngColumn = 3 'usw.....

versuchs mal so:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objOutlook As Object, objMail As Object
Dim lngColumn As Long
If Target.Column = 8 And Target.Row > 1 Then
If Not IsEmpty(Target.Value) Then
Select Case Target.Value
Case "Arbeitsschutz"
lngColumn = 1
Application.EnableEvents = False
Cells(Target.Row, 4) = Cells(Target.Row, 4) & 1
'hier müsste eine Sortierfunktion zum splitten und sortieren der
'gerade entstandenen Ziffernfolge eingefügt werden
Cells(Target.Row, 5) = Replace(Cells(Target.Row, 5), 1, "")
Application.EnableEvents = True
Case "Datenschutz"
lngColumn = 3
Application.EnableEvents = False
Cells(Target.Row, 4) = Cells(Target.Row, 4) & 2
'hier müsste eine Sortierfunktion zum splitten und sortieren der
'gerade entstandenen Ziffernfolge eingefügt werden
Cells(Target.Row, 5) = Replace(Cells(Target.Row, 5), 2, "")
Application.EnableEvents = True
Case "AGG"
lngColumn = 5
Application.EnableEvents = False
Cells(Target.Row, 4) = Cells(Target.Row, 4) & 3
'hier müsste eine Sortierfunktion zum splitten und sortieren der
'gerade entstandenen Ziffernfolge eingefügt werden
Cells(Target.Row, 5) = Replace(Cells(Target.Row, 5), 3, "")
Application.EnableEvents = True
Case "Korruption"
lngColumn = 7
Application.EnableEvents = False
Cells(Target.Row, 4) = Cells(Target.Row, 4) & 4
'hier müsste eine Sortierfunktion zum splitten und sortieren der
'gerade entstandenen Ziffernfolge eingefügt werden
Cells(Target.Row, 5) = Replace(Cells(Target.Row, 5), 4, "")
Application.EnableEvents = True
End Select
Set objOutlook = CreateObject(Class:="Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = Cells(Target.Row, 3).Text
.Subject = Worksheets("Tabelle3").Cells(2, lngColumn).Text
.Body = Worksheets("Tabelle3").Cells(2, lngColumn + 1).Text
Call .Display
End With
Set objMail = Nothing
Set objOutlook = Nothing
End If
End If
End Sub

Für die Function Splitten (der Ziffernfolge z.B. 3421) und aufsteigend Sortieren bin ich raus,
da müsste jemand anderes helfen :-)
Gruß
Jochen

Beliebteste Forumthreads (12 Monate)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread