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