Hallo liebe Community,

Wenn Sie die zeitliche Abfolge von Aufgaben in einem Projekt auf einen Blick sehen wollen, wird Ihnen Gantt-Diagramme weiterhelfen.
Ich werde heute Ihnen einen Code vorstellen, der Excel in die Lage versetz, Balkendiagramme wie MS-Project zu erstellen.

Ein Zusammenspiel zwischen einer strukturierten Excel- Arbeitsmappe und VBA-Code wird uns das Vorhaben ermöglichen.
Gehen Sie wie folgt vor, um die gewünschte Arbeitsmappe zu erstellen.
1) Starten Sie Excel
2) Wenn Sie kein Arbeitsblatt sehen. Fügen Sie eine neue Arbeitsmappe ein (Datei--> Neu--> Leere Arbeitsmappe)
3) Wechseln Sie mit Tastenkombination Alt+F11 zu VBA -Editor
4) Fügen Sie zwei Module und ein Klassenmodul ein (Einfügen--> Modul/Klassenmodul)
5) Aendern Sie den Namen des Klassenmoduls von Klasse1 auf "clsTimebarX" um
6) Speichern Sie die Arbeitsmappe (Excel-Arbeitsmappe mit Makros (*.xlsm). Geben Sie einen neuen Namen für die Datei ein
7) Kopieren Sie den folgenden Code und fügen Sie ihn in Modul1 ein.


'######################################

'Modul1 Beginn

'######################################
Option Explicit
Option Compare Text

'arbeitsmappe vorbereiten

Sub Dokument_Mit_Strucktur_Erstellen()

'neues workbook erstellen
'Workbooks.Add

'bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False

With Application.ActiveWorkbook
'ein neues arbeitsblatt einfügen
.Sheets.Add After:=Sheets(Sheets.Count)
'arbeitsblatt umbenennen
.Worksheets(Sheets.Count).Name = "Proj_1"
End With

With Application.Worksheets("Proj_1")
.Rows("1:1610").RowHeight = 15
.Rows("1:1").EntireRow.Hidden = True
.Columns("A").ColumnWidth = 12
.Columns("A").EntireColumn.Hidden = True
.Columns("B").ColumnWidth = 3
.Columns("C").ColumnWidth = 39
.Columns("D").ColumnWidth = 30
.Columns("E").ColumnWidth = 7.14
.Columns("F").ColumnWidth = 1
.Columns("G").ColumnWidth = 8
.Columns("H").ColumnWidth = 8
.Columns("R").ColumnWidth = 8

.Columns("T").ColumnWidth = 1
.Columns("G:S").ColumnWidth = 8
.Columns("U:X").ColumnWidth = 12
.Columns("Y").ColumnWidth = 30
.Columns("Z:AC").ColumnWidth = 11
End With

Range("A8").Select
ActiveCell.FormulaR1C1 = "=MAX(R10C1:R1500C1)"
Range("A10").Select
ActiveCell.FormulaR1C1 = "=IF(OR(RC[2]<> """",RC[3]<>""""),ROW(RC)-9,0)"
Range("A10").Select
Selection.AutoFill Destination:=Range("A10:A51"), Type:=xlFillDefault
Range("W10").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]=0,0,VLOOKUP(RC[-2],R10C1:R1500C24,24,FALSE)+RC[-1])"
Range("W10").Select
Selection.AutoFill Destination:=Range("W10:W51"), Type:=xlFillDefault
Range("X10").Select
ActiveCell.FormulaR1C1 = "=RC[-1]+RC[-19]"
Range("X10").Select
Selection.AutoFill Destination:=Range("X10:X51"), Type:=xlFillDefault
Range("X10:X51").Select

Range("H4").Select
ActiveCell.FormulaR1C1 = "=MAX(R10C24:R1500C24)"
Range("G4").Select
ActiveCell.FormulaR1C1 = "Istzeit"
Range("G5").Select
ActiveCell.FormulaR1C1 = "Sollzeit"

Range("W7:W9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

Range("X7:X9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Copy
Range("U7:U9").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Range("V7:V9").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("Y7:Y9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("E7:E9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("C7:C9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("D7:D9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("E7:E9").Select
ActiveCell.FormulaR1C1 = "ZEIT [h]"
Range("E7:E9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("C7:C9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("D7:D9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("H5").Select
ActiveCell.FormulaR1C1 = "30"
Range("U7:Y9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Range("G7:G9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Copy
Range("H7:S9").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("F7:F9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("B10").Select
ActiveCell.FormulaR1C1 = "1"
Range("B11").Select
ActiveCell.FormulaR1C1 = "2"
Range("B10:B11").Select
Selection.AutoFill Destination:=Range("B10:B51"), Type:=xlFillDefault
Range("B10:B51").Select
Range("B10").Select
Range("A8").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A10:B51").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("H4").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("W10").Select
Range("W10:X51").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("Y7:Y9").Select
ActiveCell.FormulaR1C1 = "Kommentar"
Range("X7:X9").Select
ActiveCell.FormulaR1C1 = "Ende"
Range("W7:W9").Select
ActiveCell.FormulaR1C1 = "Start"
Range("V7:V9").Select
ActiveCell.FormulaR1C1 = "Offset"
Range("U7:U9").Select
ActiveCell.FormulaR1C1 = "Vorgänger"
Range("U10").Select
Range("C7:C9").Select
ActiveCell.FormulaR1C1 = "BEZEICHNUNG VORGAENGER"
Range("D7:D9").Select
ActiveCell.FormulaR1C1 = "BEZEICHNUNG VORGAENGER"
Range("U7:Y9").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("U10:V51").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("Y10").Select
Range("Y10:Y51").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("W7:W9").Select
ActiveCell.FormulaR1C1 = "Start"
Range("W7:X9").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("R7:R9").Select
ActiveSheet.Buttons.Add(300, 12, 120, 45).Select
Selection.OnAction = "Erstelle_Balken"
Selection.Name = "bt_st"
Selection.Characters.Text = "Balken Erstellen"
With Selection.Characters(Start:=1, Length:=16).Font
.Name = "Calibri"
.FontStyle = "Standard"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
Range("D10").Select
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1045, 2.75, 425 _
, 70).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"Klicken Sie auf dieses Objekt um die gelb und rot markierten Zellen auszublenden"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 80).ParagraphFormat. _
FirstLineIndent = 0
Selection.Name = "br_info"

With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 80).Font
.BaselineOffset = 0
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 22
End With
Range("L7:L9").Select
ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
Selection.OnAction = "Bereich_ausblenden"
Range("R4").Select
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1475, 2.75, 155, _
70).Select
Selection.ShapeRange.Name = "falogo"
Selection.Name = "falogo"
Selection.OnAction = "Bereich_einblenden"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"USERBEREICH EINBLENDEN"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 22).ParagraphFormat. _
FirstLineIndent = 0
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 22).Font
.BaselineOffset = 0
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 23
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent6
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With
Range("Q7:Q9").Select
ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent5
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With
Range("C12").Select
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 60, 12, 195, _
45).Select
Selection.ShapeRange.Name = "mein_logo"
Selection.Name = "mein_logo"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "IHR LOGO HIER"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 13).ParagraphFormat. _
FirstLineIndent = 0
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 13).Font
.BaselineOffset = 0
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 26
End With
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent3
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.8000000119
.Transparency = 0
.Solid
End With
Range("C11").Select
Range("B7:B9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("B7:B9").Select
ActiveCell.FormulaR1C1 = "Nr"
Range("B7:B9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("C10").Select

ActiveWindow.DisplayGridlines = False

Range("B2").Select
Range("B2:S51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B7:S9").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B10").Select
Range("B10:B51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("C12").Select
Range("U2:Y51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("U7:Y51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Range("B10:B51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B7:E9").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("C10").Select
Range("C10:E51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Range("F10:F51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDot
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("G10:S51").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDot
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDash
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With

'einige daten
Range("N3").Value = "MITARBEITER :"
Range("N4").Value = "MITARBEITER :"
Range("N5").Value = "MITARBEITER :"

Range("P3").Value = "BROWN"
Range("P4").Value = "KLEIN"
Range("P5").Value = "KROSS"

Range("I6").Value = "BITTE ROT MARKIERTEN ZELLEN NICHT AENDERN"


Range("C10").Value = "HARDWARE"
Range("C11").Value = "RAUM"
Range("C12").Value = "KABEL"
Range("C13").Value = "HARDWARE"
Range("C14").Value = "COMPUTER"
Range("C15").Value = "COMPUTER"
Range("C16").Value = "COMPUTER"
Range("C17").Value = "COMPUTER"
Range("C18").Value = "WLAN"
Range("C19").Value = "SURFEN"

Range("D10").Value = "BESCHAFFEN"
Range("D11").Value = "VORBEREITEN"
Range("D12").Value = "VORVERLEGEN"
Range("D13").Value = "TRANSPORTIEREN"
Range("D14").Value = "POSITIONIEREN"
Range("D15").Value = "VORBEREITEN"
Range("D16").Value = "VERKABELN"
Range("D17").Value = "SOFTWARE INSTALLIEREN"
Range("D18").Value = "EINRICHTEN"
Range("D19").Value = "GANZEN TAG"


Range("E10").Value = 5
Range("E11").Value = 4
Range("E12").Value = 8
Range("E13").Value = 7
Range("E14").Value = 4
Range("E15").Value = 1
Range("E16").Value = 2
Range("E17").Value = 2
Range("E18").Value = 1
Range("E19").Value = 3


Range("U11").Value = 1
Range("U12").Value = 2
Range("U13").Value = 3
Range("U14").Value = 4
Range("U15").Value = 5
Range("U16").Value = 6
Range("U17").Value = 7
Range("U18").Value = 7
Range("U19").Value = 8

Range("Y10").Value = "BROWN"
Range("Y11").Value = "BROWN"
Range("Y12").Value = "KLEIN"
Range("Y13").Value = "KROSS"
Range("Y14").Value = "BROWN"
Range("Y15").Value = "KLEIN"
Range("Y16").Value = "BROWN"
Range("Y17").Value = "KROSS"
Range("Y18").Value = "BROWN"
Range("Y19").Value = "BROWN"

'fenster einfrieren
Range("F10").Select
ActiveWindow.FreezePanes = True
Range("C10").Select

'druckbereich festlegen
ActiveSheet.PageSetup.PrintArea = "$B$2:$S$51"

With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.787401575)
.BottomMargin = Application.InchesToPoints(0.787401575)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Zoom = 100
End With

Application.ScreenUpdating = True
End Sub

'Modul1 Ende

'##############################################################################################################################
'##############################################################################################################################


8) Kopieren Sie den folgenden Code und fügen Sie ihn in Modul2 ein

'######################################################

'Modul2 Beginn

'######################################################

Option Explicit
Option Compare Text

Sub Erstelle_Balken()

Dim VarZell As Variant
Dim Klas As clsTimebarX

On Error GoTo ErH
VarZell = Application.ActiveCell.Address
Set Klas = New clsTimebarX
Call Klas.ClearShapes
If Range("A8").Value > 0 And Not IsError(Range("H4")) Then
Call Klas.CreateTimeBar(True) 'mit kommentar erstellen
Else
MsgBox "Dokument ist fehlerhaft", vbCritical, "LAZIGO78"
End If

ErH:
If Err <> 0 Then
MsgBox Err.Description, vbExclamation, "LAZIGO78"
End If
Set Klas = Nothing

Range(VarZell).Select

'tastenkombination Strg+Untbr in kraft setzen
If Application.EnableCancelKey = xlDisabled Then
Application.EnableCancelKey = xlInterrupt
End If

End Sub

'userbereich ausblenden
Public Sub Bereich_ausblenden()
Dim i As Integer
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
Columns("T:Y").EntireColumn.Hidden = True
Next i
Application.ScreenUpdating = True
End Sub

'userbereich einblenden
Public Sub Bereich_einblenden()
Dim i As Integer
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
Columns("T:Y").EntireColumn.Hidden = False
Next i
Application.ScreenUpdating = True
End Sub


'Modul2 Ende
'######################################################################################################################
'######################################################################################################################


9) Kopieren Sie den folgenden Code und fügen Sie ihn in Klassenmodul „clsTimebarX“ ein


'###############################################################

'clsTimebarX Beginn

'##############################################################

Private DbStart As Double
Private DbFakt As Double
Private DbMaxZeitAchse As Double
Private BlAchseNicht As Boolean
Option Compare Text
Option Explicit


Function TimeAxis()

Dim Int_J As Integer
Dim Dbl_Li As Double
Dim DblStartWert As Double
Dim StrCur As String
Dim DblSollWer As Double
Dim VarIstWert
Dim DblEndAchse As Double
Dim DblSchritt As Double
Dim Obj_Non As Object
Dim DblAnzg As Double
Dim Wsh_Ws As Worksheet

'tastenkombination Strg+Untbr ausser kraft setzen
If Application.EnableCancelKey <> xlDisabled Then
Application.EnableCancelKey = xlDisabled
End If

BlAchseNicht = False
Set Wsh_Ws = Application.Worksheets("Proj_1")
With Wsh_Ws
DblSollWer = .Range("H5").Value
VarIstWert = .Range("H4").Value
If DblSollWer >= VarIstWert Then
DblEndAchse = DblSollWer + 2
Else
DblEndAchse = VarIstWert + 2
End If
'bis max 2000 zulassen
If DblEndAchse > 2000.009 Then DblEndAchse = 2000

Select Case DblEndAchse
Case 0 To 16.009
DbFakt = 3.97
DblSchritt = 1
DbMaxZeitAchse = 16
DblAnzg = 16

Case 16.01 To 18.009
DbFakt = 3.535
DblSchritt = 1
DbMaxZeitAchse = 18
DblAnzg = 18

Case 18.01 To 20.009
DbFakt = 3.185
DblSchritt = 1
DbMaxZeitAchse = 20
DblAnzg = 20

Case 20.01 To 22.009
DbFakt = 2.9
DblSchritt = 1
DbMaxZeitAchse = 22
DblAnzg = 22

Case 22.01 To 24.009
DbFakt = 2.65
DblSchritt = 1
DbMaxZeitAchse = 24
DblAnzg = 24

Case 24.01 To 26.009
DbFakt = 2.45
DblSchritt = 1
DbMaxZeitAchse = 26
DblAnzg = 26

Case 26.01 To 28.009
DbFakt = 2.29
DblSchritt = 1
DbMaxZeitAchse = 28
DblAnzg = 28

Case 28.01 To 30.009
DbFakt = 2.135
DblSchritt = 1
DbMaxZeitAchse = 30
DblAnzg = 30

Case 30.01 To 32.009
DbFakt = 1.99
DblSchritt = 2
DbMaxZeitAchse = 32
DblAnzg = 32

Case 32.01 To 34.009
DbFakt = 1.8775
DblSchritt = 2
DbMaxZeitAchse = 34
DblAnzg = 34

Case 34.01 To 36.009
DbFakt = 1.775
DblSchritt = 2
DbMaxZeitAchse = 36
DblAnzg = 36

Case 36.01 To 38.009
DbFakt = 1.68
DblSchritt = 2
DbMaxZeitAchse = 38
DblAnzg = 38

Case 38.01 To 40.009
DbFakt = 1.6
DblSchritt = 2
DbMaxZeitAchse = 40
DblAnzg = 40

Case 40.01 To 42.009
DbFakt = 1.52
DblSchritt = 2
DbMaxZeitAchse = 42
DblAnzg = 42

Case 42.01 To 45.009
DbFakt = 1.425
DblSchritt = 3
DbMaxZeitAchse = 45
DblAnzg = 45

Case 45.01 To 48.009
DbFakt = 1.3385
DblSchritt = 3
DbMaxZeitAchse = 48
DblAnzg = 48

Case 48.01 To 51.009
DbFakt = 1.245
DblSchritt = 3
DbMaxZeitAchse = 51
DblAnzg = 51

Case 51.01 To 54.009
DbFakt = 1.18
DblSchritt = 3
DbMaxZeitAchse = 54
DblAnzg = 54

Case 54.01 To 57.009
DbFakt = 1.125
DblSchritt = 3
DbMaxZeitAchse = 57
DblAnzg = 57

Case 57.01 To 60.009
DbFakt = 1.06
DblSchritt = 4
DbMaxZeitAchse = 60
DblAnzg = 60

Case 60.01 To 64.009
DbFakt = 1#
DblSchritt = 4
DbMaxZeitAchse = 64
DblAnzg = 64

Case 64.01 To 70.009
DbFakt = 0.905
DblSchritt = 5
DbMaxZeitAchse = 70
DblAnzg = 70

Case 70.01 To 75.009
DbFakt = 0.845
DblSchritt = 5
DbMaxZeitAchse = 75
DblAnzg = 75

Case 75.01 To 80.009
DbFakt = 0.795
DblSchritt = 5
DbMaxZeitAchse = 80
DblAnzg = 80

Case 80.01 To 85.009
DbFakt = 0.75
DblSchritt = 5
DbMaxZeitAchse = 85
DblAnzg = 85

Case 85.01 To 90.009
DbFakt = 0.71
DblSchritt = 5
DbMaxZeitAchse = 90
DblAnzg = 90

Case 90.01 To 95.009
DbFakt = 0.67
DblSchritt = 5
DbMaxZeitAchse = 95
DblAnzg = 95

Case 95.01 To 100.009
DbFakt = 0.635
DblSchritt = 5
DbMaxZeitAchse = 100
DblAnzg = 100

Case 100.01 To 110.009
DbFakt = 0.58
DblSchritt = 5
DbMaxZeitAchse = 110
DblAnzg = 110

Case 110.01 To 120.009
DbFakt = 0.53
DblSchritt = 5
DbMaxZeitAchse = 120
DblAnzg = 120

Case 120.01 To 130.009
DbFakt = 0.49
DblSchritt = 5
DbMaxZeitAchse = 130
DblAnzg = 130

Case 130.01 To 140.009
DbFakt = 0.458
DblSchritt = 5
DbMaxZeitAchse = 140
DblAnzg = 140

Case 140.01 To 150.009
DbFakt = 0.426
DblSchritt = 10
DbMaxZeitAchse = 150
DblAnzg = 150

Case 150.01 To 160.009
DbFakt = 0.398
DblSchritt = 10
DbMaxZeitAchse = 160
DblAnzg = 160

Case 160.01 To 170.009
DbFakt = 0.373
DblSchritt = 10
DbMaxZeitAchse = 170
DblAnzg = 170

Case 170.01 To 180.009
DbFakt = 0.353
DblSchritt = 10
DbMaxZeitAchse = 180
DblAnzg = 180

Case 180.01 To 190.009
DbFakt = 0.335
DblSchritt = 10
DbMaxZeitAchse = 190
DblAnzg = 190

Case 190.01 To 200.009
DbFakt = 0.318
DblSchritt = 10
DbMaxZeitAchse = 200
DblAnzg = 200

Case 200.01 To 220.009
DbFakt = 0.29
DblSchritt = 10
DbMaxZeitAchse = 220
DblAnzg = 220

Case 220.01 To 240.009
DbFakt = 0.265
DblSchritt = 10
DbMaxZeitAchse = 240
DblAnzg = 240

Case 240.01 To 260.009
DbFakt = 0.245
DblSchritt = 10
DbMaxZeitAchse = 260
DblAnzg = 260

Case 260.01 To 280.009
DbFakt = 0.2295
DblSchritt = 10
DbMaxZeitAchse = 280
DblAnzg = 280

Case 280.01 To 300.009
DbFakt = 0.213
DblSchritt = 15
DbMaxZeitAchse = 300
DblAnzg = 300

Case 300.01 To 325.009
DbFakt = 0.1965
DblSchritt = 25
DbMaxZeitAchse = 325
DblAnzg = 325

Case 325.01 To 350.009
DbFakt = 0.182
DblSchritt = 25
DbMaxZeitAchse = 350
DblAnzg = 350

Case 350.01 To 375.009
DbFakt = 0.17005
DblSchritt = 25
DbMaxZeitAchse = 375
DblAnzg = 375

Case 375.01 To 400.009
DbFakt = 0.159
DblSchritt = 25
DbMaxZeitAchse = 400
DblAnzg = 400

Case 400.01 To 425.009
DbFakt = 0.15
DblSchritt = 25
DbMaxZeitAchse = 425
DblAnzg = 425

Case 425.01 To 450.009
DbFakt = 0.1415
DblSchritt = 25
DbMaxZeitAchse = 450
DblAnzg = 450

Case 450.01 To 475.009
DbFakt = 0.1345
DblSchritt = 25
DbMaxZeitAchse = 475
DblAnzg = 475

Case 475.01 To 500.009
DbFakt = 0.1275
DblSchritt = 25
DbMaxZeitAchse = 500
DblAnzg = 500

Case 500.01 To 525.009
DbFakt = 0.1217
DblSchritt = 25
DbMaxZeitAchse = 525
DblAnzg = 525

Case 525.01 To 550.009
DbFakt = 0.1165
DblSchritt = 25
DbMaxZeitAchse = 550
DblAnzg = 550

Case 550.01 To 575.009
DbFakt = 0.11155
DblSchritt = 25
DbMaxZeitAchse = 575
DblAnzg = 575

Case 575.01 To 600.009
DbFakt = 0.1065
DblSchritt = 25
DbMaxZeitAchse = 600
DblAnzg = 600

Case 600.01 To 625.009
DbFakt = 0.1025
DblSchritt = 25
DbMaxZeitAchse = 625
DblAnzg = 625

Case 625.01 To 650.009
DbFakt = 0.0985
DblSchritt = 25
DbMaxZeitAchse = 650
DblAnzg = 650


Case 650.01 To 700.009
DbFakt = 0.09125
DblSchritt = 50
DbMaxZeitAchse = 700
DblAnzg = 700

Case 700.01 To 750.009
DbFakt = 0.085
DblSchritt = 50
DbMaxZeitAchse = 750
DblAnzg = 750

Case 750.01 To 800.009
DbFakt = 0.08
DblSchritt = 50
DbMaxZeitAchse = 800
DblAnzg = 800

Case 800.01 To 850.009
DbFakt = 0.075
DblSchritt = 50
DbMaxZeitAchse = 850
DblAnzg = 850

Case 850.01 To 900.009
DbFakt = 0.07115
DblSchritt = 50
DbMaxZeitAchse = 900
DblAnzg = 900


Case 900.01 To 950.009
DbFakt = 0.0673
DblSchritt = 50
DbMaxZeitAchse = 950
DblAnzg = 950

Case 950.01 To 1000.009
DbFakt = 0.0634
DblSchritt = 50
DbMaxZeitAchse = 1000
DblAnzg = 1000

Case 1000.01 To 1100.009
DbFakt = 0.0575
DblSchritt = 100
DbMaxZeitAchse = 1100
DblAnzg = 1100

Case 1100.01 To 1200.009
DbFakt = 0.0527
DblSchritt = 100
DbMaxZeitAchse = 1200
DblAnzg = 1200

Case 1200.01 To 1300.009
DbFakt = 0.0485
DblSchritt = 100
DbMaxZeitAchse = 1300
DblAnzg = 1300

Case 1300.01 To 1400.009
DbFakt = 0.04495
DblSchritt = 100
DbMaxZeitAchse = 1400
DblAnzg = 1400

Case 1400.01 To 1500.009
DbFakt = 0.0422
DblSchritt = 100
DbMaxZeitAchse = 1500
DblAnzg = 1500

Case 1500.01 To 1600.009
DbFakt = 0.0395
DblSchritt = 100
DbMaxZeitAchse = 1600
DblAnzg = 1600

Case 1600.01 To 1700.009
DbFakt = 0.03725
DblSchritt = 100
DbMaxZeitAchse = 1700
DblAnzg = 1700

Case 1700.01 To 1800.009
DbFakt = 0.03525
DblSchritt = 100
DbMaxZeitAchse = 1800
DblAnzg = 1800

Case 1800.01 To 2000.009
DbFakt = 0.03175
DblSchritt = 100
DbMaxZeitAchse = 2000
DblAnzg = 2000

'83,3 arbeitstage

Case Else
Application.ScreenUpdating = True
MsgBox "Step Error !", vbExclamation, "LAZIGO78"
BlAchseNicht = True
Exit Function
End Select

'vorhandene shapes löschen
Call ClearShapes

End With
'zeitachse erzeugen
For Int_J = 0 To DblAnzg Step DblSchritt
Dbl_Li = DbStart
DblStartWert = Int_J
StrCur = DblStartWert
Dbl_Li = DbStart + DblStartWert * 9 * DbFakt - 10.85
Set Obj_Non = Wsh_Ws.Shapes.AddTextbox(msoTextOrientationHorizontal, Dbl_Li, 103, 25, 10)
With Obj_Non.TextFrame
.Characters.Text = StrCur
.Characters.Font.Name = "Arial"
.Characters.Font.Size = 8
.AutoSize = True
End With
Obj_Non.Select
Application.Selection.ShapeRange.Line.Visible = msoFalse
Application.Selection.ShapeRange.Fill.Visible = msoFalse
Next Int_J

End Function


Function ClearShapes()

Dim objTDocum As Object
Dim intNumShapes As Integer
Dim Obj_S As Object

If Application.EnableCancelKey <> xlDisabled Then
Application.EnableCancelKey = xlDisabled
End If
Set objTDocum = Application.Worksheets("Proj_1")
intNumShapes = objTDocum.Shapes.Count
If intNumShapes > 0 Then
For Each Obj_S In objTDocum.Shapes
If Obj_S.Name <> "br_info" And Obj_S.Name <> "falogo" And Obj_S.Name <> "bt_st" And Obj_S.Name <> "mein_logo" Then
Obj_S.Delete
End If
Next Obj_S
End If
End Function


Sub CreateTimeBar(PrintComment As Boolean)
'
Dim Int_i As Integer
Dim DblSpB As Double
Dim DblSpC As Double
Dim DblSpD As Double
Dim DblSpE As Double
Dim DblSpF As Double
Dim DblSpG As Double
Dim DblSpH As Double
Dim DblSpI As Double
Dim DblSpJ As Double
Dim DblSpM As Double
Dim DblSpN As Double
Dim DblSpO As Double
Dim DblSpP As Double
Dim DblSpQ As Double
Dim DblSpR As Double
Dim IntAnzTakt As Integer
Dim DblOffsetwert As Double
Dim Dbl_Li As Double, Dbl_Lh As Double
Dim Dbl_Breit As Double
Dim Dbl_Obe As Double
Dim Dbl_Hoe As Double
Dim DblDauerT As Double
Dim DblStartT As Double
Dim DblStopT As Double
Dim IntVorga As Integer
Dim StrComment As String
Dim DblAnfangPosLinks As Double
Dim DblMaxlng As Double
Dim DblFTime As Double
Dim DblPlzDan As Double
Dim DblPlzVor As Double
Dim Dblkal As Double
Dim DblDifrz As Double
Dim Wshwks As Worksheet
Dim IntLa As Integer

Dim objShp As Object
Dim objTfr As Object


If Application.EnableCancelKey <> xlDisabled Then
Application.EnableCancelKey = xlDisabled
End If
Application.ScreenUpdating = False
Set Wshwks = Application.Worksheets("Proj_1")
With Wshwks
'spaltenbreite und zeilenhöhe festlegen
.Select
DblSpB = 3
DblSpC = 39
DblSpD = 30
DblSpE = 7.14
DblSpF = 1
DblSpG = 8
DblSpH = 8
DblSpR = 8

.Rows("1:1610").RowHeight = 15
.Rows("1:1").EntireRow.Hidden = True 'Zeile 1 ausblenden
.Columns("A").ColumnWidth = 12
.Columns("A").EntireColumn.Hidden = True 'spalte A ausblenden
.Columns("B").ColumnWidth = DblSpB
.Columns("C").ColumnWidth = DblSpC
.Columns("D").ColumnWidth = DblSpD
.Columns("E").ColumnWidth = DblSpE
.Columns("F").ColumnWidth = DblSpF
.Columns("G").ColumnWidth = DblSpG
.Columns("H").ColumnWidth = DblSpH
.Columns("R").ColumnWidth = DblSpR

.Columns("T").ColumnWidth = 1
.Columns("G:S").ColumnWidth = 8
.Columns("U:X").ColumnWidth = 12
.Columns("Y").ColumnWidth = 30
.Columns("Z:AC").ColumnWidth = 11
'
'startwert definieren erforderlich für die erstellung der shape-objekte
DbStart = DblSpB * 5.25 + 3.85 + DblSpC * 5.25 + 3.85 + DblSpD * 5.25 + 3.85 _
+ DblSpE * 5.25 + 3.85 + DblSpF * 5.25 + 3.85

'zeitachse erzeugen
Call TimeAxis

'wenn keine Zeitachse
If BlAchseNicht = True Then: Application.ScreenUpdating = True: Exit Sub
'bildschirmpositionen
DblAnfangPosLinks = DbStart
DblMaxlng = DbMaxZeitAchse * 9 * DbFakt
DblFTime = DblAnfangPosLinks + DblMaxlng

IntAnzTakt = .Range("A8")

'zeitliche abfolge von aufgaben durchlaufen
For Int_i = 10 To IntAnzTakt + 9

IntVorga = .Cells(Int_i, 21)
DblDauerT = .Cells(Int_i, 5)
DblStartT = .Cells(Int_i, 23)
DblStopT = .Cells(Int_i, 24)
DblOffsetwert = .Cells(Int_i, 22)
Dbl_Li = DbStart
Dbl_Breit = DblDauerT * 9 * DbFakt
Dbl_Obe = (Int_i - 9) * 15 + 4.25 + 105 '15 = zeilenhöhe 4.25 = Z-verhältnisfaktor
Dbl_Hoe = 6.75
Dbl_Li = DbStart + DblStartT * 9 * DbFakt

If Int_i = 10 Then GoTo tschuk
'linien erzeugen
If IntVorga > 0 And DblDauerT > 0 Then
If .Cells(IntVorga + 9, 5) > 0 Then
If DblOffsetwert > 0 Then
'vertikal
Dbl_Li = Dbl_Li - (DblOffsetwert * 9 * DbFakt)
.Shapes.AddLine(Dbl_Li, IntVorga * 15 + 9.75 + 105, Dbl_Li, Dbl_Obe + 3.285).Select
With Application.Selection
.ShapeRange.Line.Weight = 0.2
.ShapeRange.Line.DashStyle = msoLineRoundDot 'msoLineSolid '
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.ForeColor.SchemeColor = 8 '.Interior.ColorIndex = 3
End With
'horizontal
Dbl_Lh = Dbl_Li + (DblOffsetwert * 9 * DbFakt)
.Shapes.AddLine(Dbl_Li, Dbl_Obe + 3.285, Dbl_Lh, Dbl_Obe + 3.285).Select
With Application.Selection
.ShapeRange.Line.Weight = 0.05
.ShapeRange.Line.DashStyle = msoLineRoundDot 'msoLineSolid '
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.ForeColor.SchemeColor = 8 '.Interior.ColorIndex = 3
End With

Dbl_Li = DbStart + (DblStartT * 9 * DbFakt)
Else
.Shapes.AddLine(Dbl_Li, IntVorga * 15 + 9.75 + 105, Dbl_Li, Dbl_Obe).Select
With Application.Selection
.ShapeRange.Line.Weight = 0.05
.ShapeRange.Line.DashStyle = msoLineRoundDot
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.ForeColor.SchemeColor = 8 '.Interior.ColorIndex = 3
End With
End If
End If
End If

tschuk:
If DblDauerT > 0 Then
'kommentar eintragen
If PrintComment = True Then ' kommentar mitdrucken
StrComment = DblStopT & "h " & .Cells(Int_i, 25)
Else
StrComment = DblStopT & "h"
End If
'shape rechteck erzeugen
.Shapes.AddShape(msoShapeRectangle, Dbl_Li, Dbl_Obe + 0.5, Dbl_Breit, Dbl_Hoe).Select

With Application.Selection
.ShapeRange.Fill.ForeColor.SchemeColor = 8
.Placement = xlMoveAndSize
.PrintObject = True
.ShapeRange.Line.Style = msoLineThinThin
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 0.25
End With
End With

DblPlzDan = DblFTime - (Dbl_Li + Dbl_Breit)
If DblPlzDan < 0 Then DblPlzDan = 0
DblPlzVor = Dbl_Li - DblAnfangPosLinks
If DblPlzVor < 0 Then DblPlzVor = 0
If DblPlzDan = 0 And DblPlzVor = 0 Then GoTo hahaha

'textbox erzeugen
Set objShp = .Shapes.AddShape(msoShapeRectangle, Dbl_Li - 5 + Dbl_Breit + 2, Dbl_Obe - 1.85, 25, 10) '-5 und -1.85 korrekturwerte

objShp.Select

With Selection
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.Fill.Visible = msoFalse
.Placement = xlMoveAndSize
.PrintObject = True
.Characters.Text = StrComment
IntLa = Len(.Characters.Text)
End With
With Selection.Characters(Start:=1, Length:=IntLa).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 6.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With


With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Orientation = xlHorizontal
.AutoSize = True
End With


Set objTfr = objShp.TextFrame2
With objTfr
.TextRange.Text = StrComment
.WordWrap = False
End With

Dblkal = objShp.Width

objShp.Select

With Selection
'freien Platz suchen
If DblPlzDan < Dblkal And DblPlzVor >= Dblkal Then
DblDifrz = -(Dbl_Breit + Dblkal + 3.75)
.ShapeRange.IncrementLeft DblDifrz
.ShapeRange.Height = 12
.ShapeRange.Width = Dblkal
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlRight
.Orientation = xlHorizontal
.ShapeRange.Fill.Visible = msoFalse
.ShapeRange.Line.Visible = msoFalse
ElseIf DblPlzDan >= Dblkal Then
.ShapeRange.Height = 12
.ShapeRange.Width = Dblkal
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.Orientation = xlHorizontal
.ShapeRange.Fill.Visible = msoFalse
.ShapeRange.Line.Visible = msoFalse
Else
'wenn weder vorne noch hinten Platz vorhanden
.Delete
Application.ScreenUpdating = True
' MsgBox "Kommentar auf position " & Int_i - 9 & " zu lang, kürzen Sie bitte Kommentar", vbOKOnly + vbInformation, "LAZIGO78"
Application.ScreenUpdating = False
End If
End With

Set objShp = Nothing
Set objTfr = Nothing
hahaha:
End If
Next
End With
Application.ScreenUpdating = True
End Sub


Private Sub Class_Initialize()
DbStart = 0
DbFakt = 0
DbMaxZeitAchse = 0
BlAchseNicht = False
End Sub


Private Sub Class_Terminate()
On Error Resume Next
On Error GoTo 0
End Sub

'clsTimebarX Ende
'################################################################################################################
'################################################################################################################

Jetzt wechseln Sie wieder zurück zu Excel mit Alt+Q und aktivieren Sie das Arbeitsblatt "Tabelle1"
Fügen Sie Eine Schaltfläche ein [Entwicklertools--> Einfügen--> Schaltfläche (Formularsteuerelement)]
Weisen Sie der Schaltfläche das Makro "Dokument_Mit_Strucktur_Erstellen" zu.
Speichern Sie die Datei.

Die Erstellung der Arbeitsmappe ist erfolgt. Wenn Sie jetzt auf die Schaltfläche klicken,
wird der aktiven Arbeitsmappe ein neues Arbeitsblatt zugefügt und der Name auf "Proj_1" umbenannt.

Das Arbeitsblatt "Proj_1" ist formatiert und einige Zellen sind mit Daten belegt.
Die rot markierten Zellen haben Excel-Funktionen . Bitte gehen Sie mit diesen Zellen äußerst behutsam vor und ändern Sie die nicht.
Auf dem Arbeitsblatt "Proj_1" finden Sie eine Schaltfläche mit Überschrift "Balken Erstellen".
Wenn Sie auf die Schaltfläche klicken wird Balkendiagramm in Abhängigkeit von den Daten dargestellt.

Der Code ist unter Excel 2010/2013 (deutsche Version) 32bit und 64bit lauffähig


Ich wünsche euch viel Spaß damit