Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 00:42:03
Listbox mit gefilterten Daten füllen
24.04.2024 20:38:58
Summe mit Bedingung, nur letzte Ergebnisse anzeigen
24.04.2024 19:29:30
Formel filter
24.04.2024 18:49:56
merge & select
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1716to1720
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1716to1720
1716to1720
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Automatisierter Urlaubskalender

Automatisierter Urlaubskalender
11.10.2019 12:45:18
Dete
Hallo Leute,
ich habe eine Frage bzw. ein Problem, für das ich bisher leider nur VBA-Teillösungen im Netz gefunden habe und diese nicht zusammengebastelt bekomme.
Also ich soll einen automatisierten Excel-Urlaubskalender für den Chef erstellen, der ihm eine Übersicht über alle Urlaubswünsche für das nächste Jahr gibt und auf den jeder Mitarbeiter im Firmennetz Zugriff hat.
Dabei sollen die Mitarbeiter ihre Urlaubswünsche (Zeiträume) jeweils in ein eigenes aber vordefiniertes Tabellenblatt (jeweils "Nachname") eintragen. Diese Zeiträume werden dann im "Übersichtsblatt" als Farbbalken in den entsprechenden Zeilen der Mitarbeiter dargestellt, um Überlagerungen zu erkennen. So weit so gut. Dieses Grundgerüst läuft bislang gut. Zumindest manuell.
Aber jetzt soll die Arbeitsmappe wie folgt automatisiert werden:
1. die individuellen Tabellenblätter ("Nachname") sollen automatisch erstellt und benannt werden, sobald der Chef in das "Übersichtsblatt" in der Spalte A einen neuen Namen hinzufügt oder einen bestehenden Namen ändert!
Bislang habe ich es nur hinbekommen, dass die Tabellenblätter nach Eingabe aller Namen einmalig zusammen nach manuellem Starten des Makros erstellt worden sind. Schön wäre es aber, wenn die Aktualisierung (Erstellung und Benennung) schon nach Eingabe jedes einzelnen Namens erfolgen würde
2. Diese individuellen Tabellenblätter für die Mitarbeiter sollen auf Grundlage eines vordefinierten Tabellenblatts erstellt werden (dieses "Musterblatt" liegt in der Arbeitsmappe schon vor)
3. es sollten keine doppelten Tabellenblätter erstellt werden, falls bereits ein Tabellenblatt zu einem Namen schon vorliegt
Ich hoffe, dass man sowas mit VBA einigermaßen umsetzen kann und hier jemand eine findige Lösung kennt :) ich jedenfalls leider nicht... :(
VG,
Dete
Muster-Datei
https://www.herber.de/bbs/user/132479.xlsx

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Was ist mit Ehepartner oder den ganzen Müllers
11.10.2019 13:03:41
RPP63
Moin!
Was passiert, wenn Gerd Müller mal eben den Urlaubswunsch von Rudi Völler ändert, weil er mit seinem kollidiert?
Findest Du die "Idee" Deines Chefs nicht ebenfalls etwas unausgereift?
So etwas regelt man entweder über eine echte Datenbank oder nimmt die altbekannte Zettel-Methode (gern in Zeiten des Neulands auch mittels E-Mail).
Fragt sich Ralf
AW: Automatisierter Urlaubskalender
11.10.2019 13:36:25
Torsten
Hallo Dete,
bitte beachte die Hinweise von Ralf. Er hat da voellig recht. Die einzelnen Tabellenblaetter muessten dann schon noch geschuetzt werden, damit keiner Aenderungen beim anderen vornehmen kann.
Doppelte Namen koennen auch ein Problem darstellen. Solltest du vielleicht drueber nachdenken, die Vornamen mit zu nehmen.
Ich hab dir mal was gebastelt, was dir bei Aenderung im Übersichtsblatt (aber nur in Spalte A), ein neues Blatt erstellt, wenn noch nicht vorhanden, nach Muster des Musterblatts und auch den Namen dort schon eintraegt.
Schau mal ob es dir so passt.
Deine Formeln in der Uebersicht muesstest du aber auch noch variabler gestalten.
Gruss Torsten
Dieser code ins Fenster unter der Tabelle Uebersichtsblatt: 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim deletValue As String
If Target.Column  1 Then Exit Sub
If SheetExists(Target.Value) Then
MsgBox "Ein Tabellenblatt mit diesem Namen existiert bereits!"
Target = ""
Exit Sub
End If
Dim sh As Worksheet
If Target.Value  "" Then
Sheets("Musterblatt").Copy After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count) _
Set sh = ActiveSheet
sh.Name = Target.Value
With Sheets(sh.Name)
.Cells(6, 1) = sh.Name
End With
End If
Sheets("Übersichtsblatt").Activate
End Sub

und dieser in ein allgemeines Modul: 

Option Explicit
Public Function SheetExists(strName As String) As Boolean
On Error Resume Next
SheetExists = Not Sheets(strName) Is Nothing
End Function

Anzeige
Crosspost ohne Hinweis....
11.10.2019 13:58:34
Werner
Hallo,
...wenn schon, dann solltest du in beiden Foren einen Hinweis auf den Beitrag im anderen Forum aufnehmen.
Gruß Werner
AW: Automatisierter Urlaubskalender
11.10.2019 14:05:14
Nepumuk
Hallo Dete,
teste mal:
Option Explicit

Private mstrOldValue As String

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objWorksheet As Worksheet
    If Target.Column = 1 And Target.CountLarge = 1 Then
        If IsEmpty(Target.Value) Then 'Name wurde gelöscht
            If OldValue <> vbNullString Then
                Set objWorksheet = GetWorksheet(OldValue)
                If Not objWorksheet Is Nothing Then
                    If MsgBox("Die Tabelle ''" & OldValue & "'' löschen?", _
                        vbQuestion Or vbYesNo, "Sicherheitsabfrage") = vbYes Then
                        Application.DisplayAlerts = False
                        Call objWorksheet.Delete
                        Application.DisplayAlerts = True
                    End If
                End If
            End If
        Else
            If OldValue = vbNullString And Not IsEmpty(Target.Value) Then 'Neuer Name in leere Zelle
                Set objWorksheet = GetWorksheet(Target.Text)
                If Not objWorksheet Is Nothing Then
                    Call MsgBox("Diesen Namen gibt es schon.", vbExclamation, "Hinweis")
                    Application.EnableEvents = False
                    Target.Value = Empty
                    Application.EnableEvents = True
                Else
                    Call CreateWorksheet(Target.Text)
                End If
            Else
                If OldValue <> vbNullString And Not IsEmpty(Target.Value) Then 'Neuer Name in belegter Zelle
                    If OldValue <> Target.Text Then
                        Set objWorksheet = GetWorksheet(Target.Text)
                        If Not objWorksheet Is Nothing Then
                            Call MsgBox("Diesen Namen gibt es schon.", vbExclamation, "Hinweis")
                            Application.EnableEvents = False
                            Target.Value = OldValue
                            Application.EnableEvents = True
                        End If
                    Else
                        Set objWorksheet = GetWorksheet(OldValue)
                        If Not objWorksheet Is Nothing Then
                            objWorksheet.Name = Target.Text
                        Else
                            Call CreateWorksheet(Target.Text)
                        End If
                    End If
                End If
            End If
        End If
    End If
    Set objWorksheet = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 1 And Target.CountLarge = 1 Then OldValue = Target.Text
End Sub

Private Function GetWorksheet(ByVal pvstrWorksheetname As String) As Worksheet
    Dim objWorksheet As Worksheet
    For Each objWorksheet In ThisWorkbook.Worksheets
        If objWorksheet.Name = pvstrWorksheetname Then
            Set GetWorksheet = objWorksheet
            Exit For
        End If
    Next
    Set objWorksheet = Nothing
End Function

Private Sub CreateWorksheet(ByVal pvstrWorksheetname As String)
    Application.ScreenUpdating = False
    Call ThisWorkbook.Worksheets("Musterblatt").Copy( _
        After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    ActiveSheet.Name = pvstrWorksheetname
    ActiveSheet.Cells(6, 1).Value = pvstrWorksheetname
    ActiveSheet.Tab.ColorIndex = xlColorIndexNone
    ThisWorkbook.Worksheets("Übersichtsblatt").Select
    Application.ScreenUpdating = True
End Sub

Private Property Get OldValue() As String
    OldValue = mstrOldValue
End Property

Private Property Let OldValue(ByVal pvstrOldValue As String)
    mstrOldValue = pvstrOldValue
End Property

Gruß
Nepumuk
Anzeige
AW: Automatisierter Urlaubskalender
11.10.2019 15:13:29
Nepumuk
Hallo Dete,
ich hab nach dem testen noch was eingebaut und dann nicht mehr getestet. Da habe ich mir glatt einen Fehler eingebaut. Also:
Option Explicit

Private mstrOldValue As String

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objWorksheet As Worksheet
    If Target.Column = 1 And Target.CountLarge = 1 Then
        If IsEmpty(Target.Value) Then 'Name wurde gelöscht
            If OldValue <> vbNullString Then
                Set objWorksheet = GetWorksheet(OldValue)
                If Not objWorksheet Is Nothing Then
                    If MsgBox("Die Tabelle ''" & OldValue & "'' löschen?", _
                        vbQuestion Or vbYesNo, "Sicherheitsabfrage") = vbYes Then
                        Application.DisplayAlerts = False
                        Call objWorksheet.Delete
                        Application.DisplayAlerts = True
                    End If
                End If
            End If
        Else
            If OldValue = vbNullString And Not IsEmpty(Target.Value) Then 'Neuer Name in leere Zelle
                Set objWorksheet = GetWorksheet(Target.Text)
                If Not objWorksheet Is Nothing Then
                    Call MsgBox("Diesen Namen gibt es schon.", vbExclamation, "Hinweis")
                    Application.EnableEvents = False
                    Target.Value = Empty
                    Application.EnableEvents = True
                Else
                    Call CreateWorksheet(Target.Text)
                End If
            Else
                If OldValue <> vbNullString And Not IsEmpty(Target.Value) Then 'Neuer Name in belegter Zelle
                    If OldValue <> Target.Text Then
                        Set objWorksheet = GetWorksheet(Target.Text)
                        If Not objWorksheet Is Nothing Then
                            Call MsgBox("Diesen Namen gibt es schon.", vbExclamation, "Hinweis")
                            Application.EnableEvents = False
                            Target.Value = OldValue
                            Application.EnableEvents = True
                        Else
                            Set objWorksheet = GetWorksheet(OldValue)
                            If Not objWorksheet Is Nothing Then
                                objWorksheet.Name = Target.Text
                                objWorksheet.Cells(6, 1).Value = Target.Text
                            Else
                                Call CreateWorksheet(Target.Text)
                            End If
                        End If
                    End If
                End If
            End If
        End If
        Set objWorksheet = Nothing
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 1 And Target.CountLarge = 1 Then OldValue = Target.Text
End Sub

Private Function GetWorksheet(ByVal pvstrWorksheetname As String) As Worksheet
    Dim objWorksheet As Worksheet
    For Each objWorksheet In ThisWorkbook.Worksheets
        If objWorksheet.Name = pvstrWorksheetname Then
            Set GetWorksheet = objWorksheet
            Exit For
        End If
    Next
    Set objWorksheet = Nothing
End Function

Private Sub CreateWorksheet(ByVal pvstrWorksheetname As String)
    Application.ScreenUpdating = False
    Call ThisWorkbook.Worksheets("Musterblatt").Copy( _
        After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    ActiveSheet.Name = pvstrWorksheetname
    ActiveSheet.Cells(6, 1).Value = pvstrWorksheetname
    ActiveSheet.Tab.ColorIndex = xlColorIndexNone
    ThisWorkbook.Worksheets("Übersichtsblatt").Select
    Application.ScreenUpdating = True
End Sub

Private Property Get OldValue() As String
    OldValue = mstrOldValue
End Property

Private Property Let OldValue(ByVal pvstrOldValue As String)
    mstrOldValue = pvstrOldValue
End Property

Gruß
Nepumuk
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige