Servus Lighty
meine Bauzeitpläne vervollständigen sich zwar dynamisch auf Eingabe der Daten aber das VBA-Modul für die Balkenbeschriftung habe ich mal kurz an deine Tabelle angepasst.
Bei der Unmenge deiner Formeln und Validierungen selbstplaudernd ohne Gewähr!
'******************************************************************************
' module: mdl_schedul / gen. 2014-03-08 07:00:35
'------------------------------------------------------------------------------
' goal
'
'******************************************************************************
'
Option Explicit
'
Dim ows As Excel.Worksheet
Dim osh As Excel.Shape
Dim dStart
'
Sub TestIt()
'
'******************************************************************************
' Name : TestIt / 2015-04-11 07:39:30 / Sub
'------------------------------------------------------------------------------
'
' die Const STARTADRESSE ggf. anpassen (ab Tätigkeit abwärts)
' die Const STARTDATUM ggf. anpassen (Beginn Kalendarium)
'
Const STARTADRESSE As String = "$O$16"
Const STARTDATUM As String = "$C$3"
'
Const m_ModName As String = "mdl_schedul"
Const m_PrcName As String = "TestIt"
Dim m_SendKey As String: m_SendKey = Chr(123) & "F8" & Chr(125)
'
'******************************************************************************
'
Dim c As Excel.Range
'
On Error GoTo TestIt_Error
'
Set ows = ThisWorkbook.ActiveSheet
ClAll 'delete subset
With ows
dStart = .Range(STARTDATUM).Value
For Each c In _
Range(.Range(STARTADRESSE).Offset(1), _
.Cells(.Rows.Count, .Range(STARTADRESSE).Column).End(xlUp))
'
If IsDate(c.Offset(, -6)) And VarType(c.Value) = 8 Then _
ChkIt c
Next c
End With
'
On Error GoTo 0
'
TestIt_Error:
'------------------------------------------------------------------------------
Select Case Err.Number
Case Is = 0: 'errorless
' Case is = #: 'custom
Case Else: 'display
Select Case MsgBox(Format(Err.Number, " #0") & "/" & Err.Description & _
Chr(13) & Chr(13) & " goto debuger ?", _
vbYesNo Or vbCritical Or vbDefaultButton1, _
m_ModName & " / " & m_PrcName)
Case vbYes
Application.SendKeys Keys:=m_SendKey & m_SendKey, Wait:=False
Stop: Resume
Case vbNo
' Abbruch
End Select
End Select
'------------------------------------------------------------------------------
Set ows = Nothing
Set osh = Nothing
End Sub
'
Private Sub MakeIt(sRng As Range, qRng As Range)
Set osh = ows.Shapes.AddShape(msoShapeRectangle, sRng.Left, sRng.Top, sRng.Width, sRng.Height)
With osh
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
With .TextFrame
With .Characters
.Text = qRng.Value
With .Font
.Bold = qRng.Font.Bold
.Size = qRng.Font.Size
End With
End With
.MarginTop = 0
.HorizontalAlignment = xlHAlignCenter
End With
End With
End Sub
'
Private Sub ChkIt(Rng As Range)
Dim Rw As Range
Dim c As Range
Dim dDiff
'
dDiff = Rng.Offset(, -7).Value - dStart
Set c = Rng.Offset(, dDiff + 1)
dDiff = Rng.Offset(, -6).Value - Rng.Offset(, -7).Value
Set Rw = Range(c, c.Offset(, dDiff))
MakeIt Rw, Rng
'
End Sub
'
Private Sub ClAll()
For Each osh In ows.Shapes
If osh.Type = msoAutoShape And osh.Line.Visible = msoFalse Then osh.Delete
Next osh
End Sub
|