Terminplanung

[Fuxxli]

Hallo zusammen

Ich würde gerne die angehängte Liste soweit optimieren, dass folgendes passiert:
Wird der Status in Spalte F per Dropdown-Liste auf Status "Vorprojekt" gesetzt, soll es im 2. Tabellenblatt "Kapa-Übersicht" einen Eintrag auf der nächsten freien Zeile erstellen mit dem Projektname gemäss Spalte B.
Zusätzlich soll anhand des vorgängig eingetragenen Datums in Spalte G ein Vorlage-Zeitstrahl auf dem 2.Tabellenblatt eingefügt werden. Dieser beginnend ab gleichem Datum wie eingetragen im 1. Tabellenblatt.

Ich habe versucht, das soweit abzubilden wie es aussehen könnte.

Aktuell ist mein Hauptproblem, dass ich nicht weiss nach welchen Schlüsselwörter ich hierfür suchen muss um ein Makro zu finden und anpassen zu können.

Hat jemand ein paar Inputs für mich nach welchen Wörtern ich suchen müsste oder hat allenfalls schon einen möglichen Code?
Verwende Office365 ProPlus mit Windows10, sollte dies noch relevant sein.

Vielen Dank für eure Hilfe 
Gruss Paul


  Kapa Auslastung Architektur TEST.xlsm (Größe: 61,18 KB / Downloads: 16)

[LCohen]

Wenn Du noch keine Idee für ein Makro hast, könntest Du ja auch eine .xlsx einstellen. Dann besorgen wir das hier, und müssen uns nicht infizieren.

[Elex]

Hi,

deinen Code durch den Ersetzen.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim j As Long, rng As Range

If Target.Column = 6 Then
  If Target.Cells.Count = 1 Then
    With Sheets("Kapa-Übersicht")
      Select Case Target.Value
        Case "Vorprojekt"
          Set rng = .Range("3:3").Find(Target.Offset(, 1).Value, , LookIn:=xlValues, lookat:=xlWhole)
            If Not rng Is Nothing Then
               j = .Cells(Rows.Count, 1).End(xlUp).Row + 1
               .Cells(j, 1).Value = Target.Offset(, -4).Value
               .Cells(j, rng.Column).Resize(1, 15).Interior.Color = RGB(204, 255, 204)
               Set rng = Nothing
            Else
               MsgBox ("Datum nicht gefunden.")
            End If
      End Select
    End With
  Else
     MsgBox ("Es wurde mehr als eine Zell geändert. Die Aktion wird Rückgängig gemacht")
     Application.EnableEvents = False
     Application.Undo
     Application.EnableEvents = True
  End If
End If

Gruß Elex

[Fuxxli]

Wenn Du noch keine Idee für ein Makro hast, könntest Du ja auch eine .xlsx einstellen. Dann besorgen wir das hier, und müssen uns nicht infizieren.

Ups macht Sinn.. Sorry dafür.
Hatte bereits ein Makro drin für die Zellformatierung (Farbe) je nach Projektstand.

---

Hi,

deinen Code durch den Ersetzen.

Gruß Elex

Hallo Elex


Vielen Dank für deine Hilfe  :17: Das sieht schon mal sehr gut aus.
Ich werde versuchen darauf aufzubauen und Beschriftungen und allenfalls verschiedene Farben für den Balken einzufügen.

Falls es nicht klappt melde ich mich gerne nochmals hier  :17:

Gruss Paul

[Fuxxli]

Hallo Elex

Vielen herzlichen Dank nochmals für deine Hilfe.
Ich konnte nun auf deiner Basis, weitere eingefärbte Zellen hinzufügen und diese entsprechend beschriften  :18:


Gruss und einen schönen Abend

[Fuxxli]

Hallo zusammen

Nun passiert folgendes:
Auf dem ersten Tabellenblatt kann ich aus einer Dropdownliste den Case "Vorprojekt" wählen, anschliessend erstellt es mir auf dem Tabellenblatt "Kapa ab Vorprojekt" einen Eintrag mit dem entsprechenden eingefärbten und beschrifteten Zellen. Das funktioniert soweit auch super.

Gerne würde ich aber noch die Funktion einbauen, dass wenn man in der Dropdownliste auf Absage geht, dass es mir den Eintrag wieder löscht. Sprich nach der Zelle mit dem Projektname suchen und Zeile löschen. Dachte ich kann es irgendwie umbauen, hatte es mal soweit, dass es mir eine Zeile löscht aber auf der Hauptseite   der untere Teil des Codes ist angedacht für die Löschung, ist jedoch in der jetzigen Form nicht brauchbar da ich nicht weiterkomme.

Dropdownliste ist in Spalte F und der Projektname ist in Spalte B. Auf dem 2. Tabellenblatt "Kapa ab Vorprojekt" findet man den Projektname wieder in Spalte A.
Ich nehme an, dass ich den Code von Elex nicht ganz richtig interpretiere und daher die Zelle nicht finde bzw. fehlt mir dann die Kenntnis die gefundene Zelle zu aktivieren um die Zeile löschen zu können. Im unteren Teil findet ihr den Code um die Löschung zu machen bzw. meinen Versuch...

Ist es zudem möglich nebst der eigentlichen Zeile auch die darunterliegende zu löschen? Habe jeweils eine Leerzeile drin um die einzelnen Projekte optisch etwas zu trennen.

Und das ganz grosse Kino wäre wenn ich zuerst eine Prüfung hätte ob bereits ein solcher Eintrag erstellt wurde --> falls ja Fehlermeldung "Projekt bereits erfasst", falls nein Code zur Erstellung des Eintrages ausführen.

Ich hoffe jemand kann mir hier weiterhelfen. Versuche mich nun seit ein paar Stunden daran und habe noch nicht wirklich den Durchblick erhalten. Ich werde sicherlich gewisse Schritt falsch interpretieren...

Vielen Dank für eure Hilfe oder Inputs  :19:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim j As Long, rng As Range

If Target.Column = 6 Then
  If Target.Cells.Count = 1 Then
    With Sheets("Kapa ab Vorprojekt")
      Select Case Target.Value
        Case "Vorprojekt"
          Set rng = .Range("3:3").Find(Target.Offset(, 1).Value, , LookIn:=xlFormulas, lookat:=xlWhole)
            If Not rng Is Nothing Then
               j = .Cells(Rows.Count, 1).End(xlUp).Row + 2
               .Cells(j, 1).Value = Target.Offset(, -4).Value
               .Cells(j, rng.Column).Resize(1, 30).Interior.Color = RGB(204, 255, 255)
               .Cells(j, rng.Column).Value = "Vorprojektphase"
               .Cells(j, rng.Column + 30).Resize(1, 50).Interior.Color = RGB(204, 255, 204)
               .Cells(j, rng.Column + 30).Value = "Projektierungsphase"
               .Cells(j, rng.Column + 80).Resize(1, 50).Interior.Color = RGB(255, 255, 153)
               .Cells(j, rng.Column + 80).Value = "Bewilligungsphase"
               .Cells(j, rng.Column + 123).Value = "Bewilligung"
               .Cells(j, rng.Column + 130).Resize(1, 70).Interior.Color = RGB(0, 204, 255)
               .Cells(j, rng.Column + 130).Value = "Ausführungsplanung"
               .Cells(j, rng.Column + 200).Value = "BAUSTART"
               Set rng = Nothing
            Else
               MsgBox ("Datum nicht gefunden.")
            End If
      End Select
    End With
  Else
     MsgBox ("Es wurde mehr als eine Zelle geändert. Die Aktion wird rückgängig gemacht")
     Application.EnableEvents = False
     Application.Undo
     Application.EnableEvents = True
  End If
  End If
 
If Target.Column = 6 Then
  If Target.Cells.Count = 1 Then
    With Sheets("Kapa ab Vorprojekt")
      Select Case Target.Value
        Case "Absage"
          Set rng = .Range("A:A").Find(Target.Offset(, -4).Value, , LookIn:=xlValues, lookat:=xlWhole)
               ActiveCell.EntireRow.Delete
               
               Set rng = Nothing
            Else
               MsgBox ("Projekt nicht gefunden.")
            End If
      End Select
    End With
  Else
     MsgBox ("Es wurde mehr als eine Zelle geändert. Die Aktion wird rückgängig gemacht")
     Application.EnableEvents = False
     Application.Undo
     Application.EnableEvents = True
  End If
  End If
 

[Elex]

Hi

sollte so klappen.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim j As Long, rng As Range, Meldung As Long

If Target.Column = 6 Then
  If Target.Cells.Count = 1 Then
    With Sheets("Kapa ab Vorprojekt")
      Select Case Target.Value
     
       Case "Vorprojekt"
          If WorksheetFunction.CountIf(.Range("A:A"), Target.Offset(, -4).Value) > 0 Then 'Test ob schon Vorhanden
             MsgBox "Projekt schon vorhanden"
          Else
           Set rng = .Range("3:3").Find(Target.Offset(, 1).Value, , LookIn:=xlFormulas, lookat:=xlWhole)
             If Not rng Is Nothing Then
               j = .Cells(Rows.Count, 1).End(xlUp).Row + 2
               .Cells(j, 1).Value = Target.Offset(, -4).Value
               .Cells(j, rng.Column).Resize(1, 30).Interior.Color = RGB(204, 255, 255)
               .Cells(j, rng.Column).Value = "Vorprojektphase"
               .Cells(j, rng.Column + 30).Resize(1, 50).Interior.Color = RGB(204, 255, 204)
               .Cells(j, rng.Column + 30).Value = "Projektierungsphase"
               .Cells(j, rng.Column + 80).Resize(1, 50).Interior.Color = RGB(255, 255, 153)
               .Cells(j, rng.Column + 80).Value = "Bewilligungsphase"
               .Cells(j, rng.Column + 123).Value = "Bewilligung"
               .Cells(j, rng.Column + 130).Resize(1, 70).Interior.Color = RGB(0, 204, 255)
               .Cells(j, rng.Column + 130).Value = "Ausführungsplanung"
               .Cells(j, rng.Column + 200).Value = "BAUSTART"
               Set rng = Nothing
             Else
               MsgBox ("Datum nicht gefunden.")
             End If
          End If
         
       Case "Absage"
          Set rng = .Range("A:A").Find(Target.Offset(, -4).Value, , LookIn:=xlFormulas, lookat:=xlWhole)
            If Not rng Is Nothing Then
               Meldung = MsgBox(Target.Offset(, -4).Value & " löschen?", vbYesNo)
               If Meldung = 6 Then
                  rng.Resize(2).EntireRow.Delete
               End If
            End If
      End Select
    End With
  Else
     MsgBox ("Es wurde mehr als eine Zelle geändert. Die Aktion wird rückgängig gemacht")
     Application.EnableEvents = False
     Application.Undo
     Application.EnableEvents = True
  End If
End If
End Sub

Gruß Elex

[Fuxxli]

Hallo Elex

Vielen vielen Dank.
Du bist der Hammer  :18: