VBA/Makro: Gleiche Monatsangaben automatisch zusammenfuehren

[Nico_KL]

Hallo Zusammen,

ich arbeite gerade an einem Projektplan, wobei ich ein Gantt-Chart auf Tagesbasis auf KW-Basis angepasst habe.
Je nachdem welche KW man sich durch Aengerung in Zelle F8 anzeigen lassen moechte, wird der Plan eben aktualisiert und zeigt automatisch die entsprechenden Wochen an.
Um eine bessere Uebersicht zu erhalten habe ich mir die Monate (Zeile 10) ebenfalls anzeigen lassen und mit einer bedingten Formatierung hat man zumindest eine gewisse farbliche Abweichung.
Nun steht aktuell ueber jeder KW der entsprechende Monat.
Ich haette gerne, dass die entsprechend gleichen Monate sich immer automatisch verbinden.
Bei jeder Aenderung der anzuzeigenden Kalenderwoche sollten die Monate sich dann wieder entsprechend anpassen und zusammenfuegen.

Nun habe ich mich selbst bereits mir Makros versucht aber bekomme es irgendwie nicht hin, dass es sich automatisch nach jeder Aenderung der KW entsprechend anpasst.
Ich habe den entsprechenden Projektplan mal als Datei angehaengt.
Ich hoffe Ihr koennt mir hierbei helfen.
Im Voraus bereits vielen Dank fuer eure Hilfe.

Gruss Nico.

[NobX]

Hallo,

Ich haette gerne, dass die entsprechend gleichen Monate sich immer automatisch verbinden.

Was genau soll sich wie verbinden? Formatierungen? Berechnungen? Die Monate haben bereits jeweils die gleiche Farbe(n).

Nun habe ich mich selbst bereits mir Makros versucht aber bekomme es irgendwie nicht hin, dass es sich automatisch nach jeder Aenderung der KW entsprechend anpasst.

Wo sind die Makros? In der Tabelle waren keine enthalten. Eventuell sind dazu gar keine Makros erforderlich, - je nachdem was Du Dir vorstellst.

Wenn möglich, bringe bitte dazu noch etwas Licht ins Dunkel, wenn Dir jemand helfen soll.

Grüße

NobX

[Nico_KL]

Ich versuche es nochmals mit Hilfe von Screenshots zu erklaeren.
Man kann ja sich durch die Aenderung der Angabe zur KW in Zelle F8 im Projektplan verschiedene Wochen anzeigen lassen. Status Quo ist, dass nun ueber jeder Woche eine Zelle mit dem entsprechenden Monat steht.

   


Ich haette es gerne wie folgt, dass je nachdem welcher Monat angezeigt wird, es sich bei aufeinander folgenden Wochen im gleichen Monat, der Monat verbindet, wie im folgenden Screenshot dargestellt.

   

Wenn man nun die KW in Zelle F8 anpasst, dann aendern sich demnach auch die Monate.
Ich hoffe es  ist etwas klarer geworden.

Vielen Dank fuer eure Hilfe.
Gruss Nico

[NobX]

Hallo,

versuch es einmal damit:

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ilng, flng, elng, Spalte, Startspalte, Maxspalte, Endspalte As Long
Dim crng, drng As Range
Dim Wert As Variant
Dim Arbeitsblatt As Worksheet

    If Not Intersect(Target, Sheet1.Range("CW_Current")) Is Nothing Then
        For ilng = 11 To Sheet1.Cells(10, Columns.Count).End(xlToLeft).Column
            For Each crng In Intersect(Rows(10), Sheet1.UsedRange)
                If crng.MergeCells Then
                    With crng.MergeArea
                    .UnMerge
                    .Value = crng.Value
                    End With
                End If
            Next crng
        Next
    End If
   
    If Not Intersect(Target, Sheet1.Range("CW_Current")) Is Nothing Then
    Startspalte = 10
    Maxspalte = Sheet1.Cells(10, Columns.Count).End(xlToLeft).Column
    Set Arbeitsblatt = ThisWorkbook.ActiveSheet
        With Arbeitsblatt
            For Spalte = Startspalte To Maxspalte
                If Cells(10, Spalte) <> Wert Then
                Endspalte = Spalte - 1
                    If Startspalte < Endspalte Then
                        For elng = Startspalte + 1 To Endspalte
                        Cells(10, elng).Value = ""
                        Next elng
                    Range(Cells(10, Startspalte), Cells(10, Endspalte)).Merge
                    End If
                    Startspalte = Spalte
                    Wert = Cells(10, Spalte).Value
                    End If
            Next Spalte
        End With
    End If
End Sub

Code gehört in das Worksheet: Sheet1

Grüße

NobX