Option Explicit
Dim ows As Excel.Worksheet
Dim osh As Excel.Shape
Dim dStart
Sub TestIt()
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
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:
Case Else:
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
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