Mefisto...diabeł czy anioł?
Mam takie male makro zaczerpniete z pliku znajomego generujace miarke zaznaczajaca aktualny tydzien na wykresie:
Sub dtln(sol As Integer)
' Marks the end of the current week.
crwkpos = Cells(16, 5).Value
If crwkpos > 6 Then
If crwkpos > 32 Then crwkpos = 32
For i = 1 To 20 * sol
r = i * 2 + 4
Range(Cells(r, crwkpos), Cells(r, crwkpos)).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = 3
End With
Next i
End If
End Sub
ale nie wiem jak go uzyc w moim w sensie nie klinie go calkowicie ...
moje makro docelowe to :
Sub Frame()
' Creates the time-bars, fills the complete part of the time-bar and marks new completion dates.
Dim i As Integer, stwk As Integer
Dim st As Integer, fn As Integer, cfn As Integer
Dim tvar1 As Integer, tvar2 As Integer
On Error GoTo Frame_Error
For i = 6 To 104
Select Case i
Case 6
stwk = Cells(i - 3, "H").Value
Case 10, 41
i = i + 1
Case 28, 53, 77, 96
stwk = Cells(i, "H").Value
i = i + 2
End Select
'od Start_week odejmij pierwszy_tydzieñ wykresu
tvar1 = (Cells(i, "E").Value - stwk)
If tvar1 - Int(tvar1) = 0 Then
tvar2 = 0
Else
tvar2 = 1
End If
'oblicznie kolumny startowej procesu
If Cells(i, "E").Value > 0 Then
'8 - kolumna H
st = Int(tvar1) + 8 + tvar2
Else
st = -100
End If
'8 - kolumna H
If st > -100 And st < 8 Then st = st + 52
'je¿eli startowa kolumna wychodzi poza "obszar wykresu"
'to nie pozwól wyj¶æ poza ten obszar
If st > 62 Then st = 62
If Cells(i, "G").Value > 1 Then Cells(i, "G").Value = 1
If Cells(i, "G").Value < 0 Then Cells(i, "G").Value = 0
If st > 0 And Cells(i, "F").Value > 0 Then
'obliczanie kolumny koñcowej procesu
fn = st - Int(-1 * Cells(i, "F").Value) - 1
'obliczanie kolumny koñcowej wykonania procesu
cfn = st + Int(-Int(-1 * Cells(i, "F").Value) * Cells(i, "G").Value) - 1
'je¿eli koñcowa kolumna wychodzi poza "obszar wykresu"
'to nie pozwól wyj¶æ poza ten obszar
If fn > 62 Then fn = 62
If cfn > 62 Then cfn = 62
With Range(Cells(i, st), Cells(i, fn))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
'zaznacz procent wykonania procesu
If cfn >= st Then
With Range(Cells(i, st), Cells(i, cfn))
With .Interior
.ColorIndex = 48
.Pattern = xlSolid
End With
End With
End If
End If
Next i
Frame_Exit:
On Error GoTo 0
Exit Sub
Frame_Error:
MsgBox "Error no. " & Err.Number & vbCr & _
"Error description: " & _
"(" & Err.Description & ")" & vbCr & _
" in procedure Frame."
Resume Frame_Exit
End Sub
Sub Sched()
' Runs the generators of schedule bars and features.
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Call Clr ' czyszczenie starych wykresów
Call Frame
Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Ma ktos jakis pomysl ?
zanotowane.pl doc.pisz.pl pdf.pisz.pl katkaras.opx.pl
Sub dtln(sol As Integer)
' Marks the end of the current week.
crwkpos = Cells(16, 5).Value
If crwkpos > 6 Then
If crwkpos > 32 Then crwkpos = 32
For i = 1 To 20 * sol
r = i * 2 + 4
Range(Cells(r, crwkpos), Cells(r, crwkpos)).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = 3
End With
Next i
End If
End Sub
ale nie wiem jak go uzyc w moim w sensie nie klinie go calkowicie ...
moje makro docelowe to :
Sub Frame()
' Creates the time-bars, fills the complete part of the time-bar and marks new completion dates.
Dim i As Integer, stwk As Integer
Dim st As Integer, fn As Integer, cfn As Integer
Dim tvar1 As Integer, tvar2 As Integer
On Error GoTo Frame_Error
For i = 6 To 104
Select Case i
Case 6
stwk = Cells(i - 3, "H").Value
Case 10, 41
i = i + 1
Case 28, 53, 77, 96
stwk = Cells(i, "H").Value
i = i + 2
End Select
'od Start_week odejmij pierwszy_tydzieñ wykresu
tvar1 = (Cells(i, "E").Value - stwk)
If tvar1 - Int(tvar1) = 0 Then
tvar2 = 0
Else
tvar2 = 1
End If
'oblicznie kolumny startowej procesu
If Cells(i, "E").Value > 0 Then
'8 - kolumna H
st = Int(tvar1) + 8 + tvar2
Else
st = -100
End If
'8 - kolumna H
If st > -100 And st < 8 Then st = st + 52
'je¿eli startowa kolumna wychodzi poza "obszar wykresu"
'to nie pozwól wyj¶æ poza ten obszar
If st > 62 Then st = 62
If Cells(i, "G").Value > 1 Then Cells(i, "G").Value = 1
If Cells(i, "G").Value < 0 Then Cells(i, "G").Value = 0
If st > 0 And Cells(i, "F").Value > 0 Then
'obliczanie kolumny koñcowej procesu
fn = st - Int(-1 * Cells(i, "F").Value) - 1
'obliczanie kolumny koñcowej wykonania procesu
cfn = st + Int(-Int(-1 * Cells(i, "F").Value) * Cells(i, "G").Value) - 1
'je¿eli koñcowa kolumna wychodzi poza "obszar wykresu"
'to nie pozwól wyj¶æ poza ten obszar
If fn > 62 Then fn = 62
If cfn > 62 Then cfn = 62
With Range(Cells(i, st), Cells(i, fn))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
'zaznacz procent wykonania procesu
If cfn >= st Then
With Range(Cells(i, st), Cells(i, cfn))
With .Interior
.ColorIndex = 48
.Pattern = xlSolid
End With
End With
End If
End If
Next i
Frame_Exit:
On Error GoTo 0
Exit Sub
Frame_Error:
MsgBox "Error no. " & Err.Number & vbCr & _
"Error description: " & _
"(" & Err.Description & ")" & vbCr & _
" in procedure Frame."
Resume Frame_Exit
End Sub
Sub Sched()
' Runs the generators of schedule bars and features.
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Call Clr ' czyszczenie starych wykresów
Call Frame
Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Ma ktos jakis pomysl ?