Microsoft Excel

Herbers Excel/VBA-Archiv

VBA Zellwert übertragen wenn

Betrifft: VBA Zellwert übertragen wenn von: Mon Ni
Geschrieben am: 22.09.2020 17:45:53

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

Betrifft: AW: VBA Zellwert übertragen wenn
von: JoWE
Geschrieben am: 22.09.2020 18:48:06

Hallo Mon Ni,

vllt. so?
            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.....

und das gleiche natürlich analog dazu in den weiteren Cases der Schulungscodes

Gruß
Jochen

Betrifft: AW: VBA Zellwert übertragen wenn
von: Mon Ni
Geschrieben am: 22.09.2020 19:04:01

Hallo Jochen!

Schon mal vielen lieben Dank - das klappt schon fast genau so, wie ich mir das vorstelle, super!
Eine Sache funktioniert aber leider noch nicht:
Sobald ich eine Person in mehrere Schulungen (nacheinander) einsetze(z.B. erst Arbeitsschutz und danach dann noch Datenschutz), dann verschwinden die offenen zwar, aber in der Spalte "Erledigte" wird dann nur die letzte angezeigt, in die ich eingesetzt habe, in dem Fall dann die "2".Stehen sollte da dann aber "12", weil ich ja auch in die erste Schulung eingesetzt habe. Ist es möglich, dass die entsprechende Zahl im Falle einer bereits erledigten dort ergänzt und nicht überschrieben wird?
Dann wäre die Sache komplett rund :)

Betrifft: AW: VBA Zellwert übertragen wenn
von: JoWE
Geschrieben am: 22.09.2020 19:20:51

versuchs mal mit dieser kleinen Anpassung
Cells(Target.Row, 4) = _
Cells(Target.Row, 4) & 1 ' so für alle Cases

Gruß
Jochen

Betrifft: AW: VBA Zellwert übertragen wenn
von: Mon Ni
Geschrieben am: 23.09.2020 11:47:11

Hallo Jochen,

wo genau soll ich diese Anpassung denn anbringen - habe es versucht, mit dem Ergebnis, dass dann leider gar nichts mehr passiert.
Kannst du mir die Anpassung vielleicht für ein komplettes Case anzeigen?
Schon mal vielen Dank :)
Gruß
Mon Ni

Betrifft: AW: VBA Zellwert übertragen wenn
von: Mon Ni
Geschrieben am: 23.09.2020 12:03:09

Vielleicht wäre noch wichtig zu ergänzen, dass die Ergänzungen unabhängig der Reihenfolge möglich sein sollen, also auch dann am besten funktionieren sollte, wenn ich z.B. mit der vierten Pflichtschulung anfange und danach dann in die erste, dann in die dritte und zum Schluss in die zweite Schulung einsetze.
Es wäre super, wenn dann unter erledigte dann am Ende auch "1234" steht und nicht "4132".

Betrifft: AW: lade bitte Deine Arbeitsmappe nochmal neu hoch
von: JoWE
Geschrieben am: 23.09.2020 12:22:40



Betrifft: AW: lade bitte Deine Arbeitsmappe nochmal neu hoch
von: JoWE
Geschrieben am: 23.09.2020 12:22:40



Betrifft: AW: lade bitte Deine Arbeitsmappe nochmal neu hoch
von: Mon Ni
Geschrieben am: 23.09.2020 12:35:39

https://www.herber.de/bbs/user/140378.xlsm

Betrifft: AW: lade bitte Deine Arbeitsmappe nochmal neu hoch
von: JoWE
Geschrieben am: 23.09.2020 15:11:47

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

Betrifft: AW: lade bitte Deine Arbeitsmappe nochmal neu hoch
von: Mon Ni
Geschrieben am: 23.09.2020 15:37:12

Superklasse! Die Sortierung wäre ein Nice-To-Have gewesen, aber so ist die Funktion schon echt TOP! Vielen Dank für die schnelle Hilfe!
LG

Betrifft: AW: Danke für die Rückmeldung
von: JoWE
Geschrieben am: 23.09.2020 15:43:12



Betrifft: AW: lade bitte Deine Arbeitsmappe nochmal neu hoch
von: JoWE
Geschrieben am: 24.09.2020 11:35:57

Hallo,

probier mal dies:
https://www.herber.de/bbs/user/140402.xlsm
habe eine tabellenbasierte Sortierung mittels einer temporär angelegten Tabelle die nach Sortierung wieder entfernt wird eingebaut. Scheint zu funktionieren.

Gruß
Jochen

Betrifft: AW: lade bitte Deine Arbeitsmappe nochmal neu hoch
von: Mon Ni
Geschrieben am: 24.09.2020 13:40:11

Hallo Jochen und nochmal vielen Dank für deine Mühen.

Sobald möglich werde ich die Datei mal austesten - als Interimslösung habe ich etwa 50 Wenn-Dann Formeln konstruiert, dass es schlichtweg egal ist, in welcher Reihenfolge die Schulungen gemacht werden.

Aber ich probiere es sobald wie möglich aus :)

Viele Grüße

Betrifft: AW: Ok, danke für die Rückmeldung owT
von: JoWE
Geschrieben am: 24.09.2020 16:28:11



Beiträge aus dem Excel-Forum zum Thema "VBA Zellwert übertragen wenn"