picklefactory
Well-known Member
- Joined
- Jan 28, 2005
- Messages
- 508
- Office Version
- 365
- Platform
- Windows
Hi folks
I've been battling with this for weeks now, but it seems to be beyond my newbie skills I'm afraid. Hoping for some help please?
I've been developing a specialist gantt chart, which is nearing completion, and I'm quite pleased with it, but the only major bug I have left (AFAIK) is this:
I'm using conditional formatting to do all the 'charting' but the range of cells in the main display I have named 'Chart', I mention this just in case I mislead anyone that I'm using an actual chart.... I'm not, it's all in cells, with formatting and code, but working very nicely.
I need to have the function to be able to create up to a max of two vertical lines (TAKT time indicators) at a given position in my range of cells being used as the main chart area. The first is determined by the value in cell C6 and the second by the value of D6. The 'chart' area is scaleable via another cell value, so I'm again using cell formatting to create the lines which works with the scale factor. My problem is that I cannot get the two lines to function independently. What I mean is, is that if I enter a value in C6... no problem, 1st line is created fine, add a 2nd value into D6, ditto... no problem there either and 2nd line is also created. My problem is that if I then alter the value in C6 only, the 1st line moves correctly, but the 2nd line is removed altogether and if I alter the value in D6, the 1st line isn't affected (Correct) but the original 2nd line remains and an additional line is created at the new value (Incorrect). I can't quite find a way to capture all variations with these two values. My list of options is this, but I cannot achieve it
C6 only > 0 then 1st line created (Working OK)
C6 & D6 > 0 then 2 lines created (Working OK)
C6 & D6 > 0 and C6 altered then replace 1st line with new but leave 2nd alone (Not working, 2nd line gets removed)
C6 & D6 > 0 and D6 altered then replace 2nd line with new but leave 1st alone (Not working, 1st line untouched but 2nd line copied to new position without removing original)
Code is below, apologies in advance for all the goto's, I know they're evil but I don't know another way of achieving the same result without them with my meagre knowledge.
The two main sections for this are under labels C6: and D6: in red
I hope you can make sense of it, I know it will be very clunky.... sorry, but best I can do.
Thanks all
I've been battling with this for weeks now, but it seems to be beyond my newbie skills I'm afraid. Hoping for some help please?
I've been developing a specialist gantt chart, which is nearing completion, and I'm quite pleased with it, but the only major bug I have left (AFAIK) is this:
I'm using conditional formatting to do all the 'charting' but the range of cells in the main display I have named 'Chart', I mention this just in case I mislead anyone that I'm using an actual chart.... I'm not, it's all in cells, with formatting and code, but working very nicely.
I need to have the function to be able to create up to a max of two vertical lines (TAKT time indicators) at a given position in my range of cells being used as the main chart area. The first is determined by the value in cell C6 and the second by the value of D6. The 'chart' area is scaleable via another cell value, so I'm again using cell formatting to create the lines which works with the scale factor. My problem is that I cannot get the two lines to function independently. What I mean is, is that if I enter a value in C6... no problem, 1st line is created fine, add a 2nd value into D6, ditto... no problem there either and 2nd line is also created. My problem is that if I then alter the value in C6 only, the 1st line moves correctly, but the 2nd line is removed altogether and if I alter the value in D6, the 1st line isn't affected (Correct) but the original 2nd line remains and an additional line is created at the new value (Incorrect). I can't quite find a way to capture all variations with these two values. My list of options is this, but I cannot achieve it
C6 only > 0 then 1st line created (Working OK)
C6 & D6 > 0 then 2 lines created (Working OK)
C6 & D6 > 0 and C6 altered then replace 1st line with new but leave 2nd alone (Not working, 2nd line gets removed)
C6 & D6 > 0 and D6 altered then replace 2nd line with new but leave 1st alone (Not working, 1st line untouched but 2nd line copied to new position without removing original)
Code is below, apologies in advance for all the goto's, I know they're evil but I don't know another way of achieving the same result without them with my meagre knowledge.
The two main sections for this are under labels C6: and D6: in red
I hope you can make sense of it, I know it will be very clunky.... sorry, but best I can do.
Thanks all
Code:
Public LabelValue As Single
Public ShapeName As Single
Private Sub Worksheet_Change(ByVal Target As Range)
'These two lines just store the last cell you were in, so it returns there on function completion
Dim PrevCell As Range
Set PrevCell = Target
Dim ScaleFactor As Single
'Check to see if scale is sufficient for time elements entered and notify minimum scale required
Dim Labour As Single
Dim Cycle As Single
Dim Max As Single
Dim CurrentScale As Single
Labour = Range("D62").Value
Cycle = Range("D63").Value
If Labour > Cycle Then
Max = Labour
Else: Max = Cycle
End If
If Range("I6").Value = "" Or Range("I6").Value = 0 Then
CurrentScale = 7.6
Else: CurrentScale = Range("I6").Value
End If
If Labour > CurrentScale Or Cycle > CurrentScale Then
MsgBox "Please amend scale. Current scale is too small to display times entered" & vbCr & _
" Minimum scale required is " & Max & " mins", vbExclamation, " Achtung Baby!"
PrevCell.Value = ""
Range("I6").Select
Exit Sub
End If
'If 'ROWS' changed then goto Rows
Dim RowRange As Range, RowChanged As Range 'If 'ROWS' changed then goto RowChange
Set RowChanged = Target(1, 1)
Set RowRange = Range("ROWS")
If Not Intersect(RowChanged, RowRange) Is Nothing Then
GoTo RowChange
End If
'If 'Scale' changed then goto ScaleChange
Dim ScaleRange As Range, ScaleChanged As Range 'If 'SCALE' changed then goto ScaleChange
Set ScaleChanged = Target(1, 1)
Set ScaleRange = Range("I6")
If Not Intersect(ScaleChanged, ScaleRange) Is Nothing Then
GoTo ScaleChange
End If
'Check if range C6 has changed (TAKT time indicator line required), if so then run function, if not then exit sub.
Dim TAKT1 As Range, TAKT1_changed As Range
Set TAKT1_changed = Target(1, 1)
Set TAKT1 = Range("C6")
If Not Intersect(TAKT1_changed, TAKT1) Is Nothing Then
GoTo C6
End If
'Check if range D6 has changed (TAKT time indicator line required), if so then run function, if not then exit sub.
Dim TAKT2 As Range, TAKT2_changed As Range
Set TAKT2_changed = Target(1, 1)
Set TAKT2 = Range("D6")
If Not Intersect(TAKT2_changed, TAKT2) Is Nothing Then
GoTo D6
Else: Exit Sub
End If
Application.ScreenUpdating = False
RowChange:
'Check if range CH6 (Number of rows) has changed, if so then change number of rows visible and print orientation
'if no change then skip to remaining sub. Range named as 'ROWS'
Dim FirstRow As Single 'First row of range to hide
Dim LastRow As Single 'Last row of range to hide, always 60
Dim RowsReqd As Single 'Use this to ensure max 51 rows is not exceeded
If Range("ROWS").Value > 50 Then
Rows("10:63").EntireRow.Hidden = False 'Unhide all rows for maximum display
Range("A10").Select
Exit Sub
Else: RowsReqd = Range("ROWS").Value
End If
FirstRow = 10 + RowsReqd ' First visible row is always 10 plus required qty of additional visible rows
LastRow = 60 'Last available row is 60
Dim RowsChange As Range, NewNumber As Range
Set NewNumber = Target(1, 1)
Set RowsChange = Range("ROWS")
If Not Intersect(NewNumber, RowsChange) Is Nothing Then
Rows("10:63").EntireRow.Hidden = False 'Unhide all rows initially
Rows(FirstRow & ":" & LastRow).EntireRow.Hidden = True
Range("A10").Select
'Set page setup as landscape or portrait dependent on number of rows in use
If RowsReqd > 40 Then
With ActiveSheet.PageSetup
.Orientation = xlPortrait
End With
Else
With ActiveSheet.PageSetup
.Orientation = xlLandscape
End With
End If
End If
Range("A10").Select
Exit Sub
[COLOR="Red"]C6:
'This section takes primary TAKT time from cell C6 and formats right hand cell border. Range "LB4" named as 'SCALE'
'"I9:KZ9" named as 'GRADS', "I9:KZ60" named as 'CHART'
ScaleFactor = Range("SCALE").Value
If Range("C6").Value + Range("D6").Value = 0 Then
With Range("CHART").Borders(xlInsideVertical) 'Clear previous TAKT time by removing ALL vertical cell borders within range 'CHART'
.LineStyle = xlLineStyleNone
End With
With Range("GRADS") 'Clear borders from 'GRADS' range
.Borders.LineStyle = xlLineStyleNone
.Interior.ColorIndex = 24
End With
GoTo ScaleChange 'Skip downwards
End If
If Range("D6").Value = 0 Or Range("D6").Value = "" Then
If Target.Address(0, 0) = "C6" Then
With Range("CHART").Borders(xlInsideVertical) 'Clear previous TAKT time by removing ALL vertical cell borders within range 'CHART'
.LineStyle = xlLineStyleNone
End With
With Range("GRADS")
.Borders.LineStyle = xlLineStyleNone 'Clear borders from 'GRADS' range
.Interior.ColorIndex = 24
End With
With Range(Cells(9, (Target * ScaleFactor) + 8), Cells(60, (Target * ScaleFactor) + 8)).Borders(xlEdgeRight)
.LineStyle = xlContinuous ' Add new TAKT time indicator line
.Weight = xlThick
.ColorIndex = 3
End With
GoTo ScaleChange 'Skip downwards
End If
Else
If Target.Address(0, 0) = "C6" Then
With Range("CHART").Borders(xlInsideVertical) 'Clear previous TAKT time by removing ALL vertical cell borders within range 'CHART'
.LineStyle = xlLineStyleNone
End With
With Range("GRADS")
.Borders.LineStyle = xlLineStyleNone 'Clear borders from 'GRADS' range
.Interior.ColorIndex = 24
End With
With Range(Cells(9, (Target * ScaleFactor) + 8), Cells(60, (Target * ScaleFactor) + 8)).Borders(xlEdgeRight)
.LineStyle = xlContinuous ' Add new TAKT time indicator line
.Weight = xlThick
.ColorIndex = 3
End With
End If
If Target.Address(0, 0) = "D6" Then
With Range(Cells(9, (Target * ScaleFactor) + 8), Cells(60, (Target * ScaleFactor) + 8)).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
End If
GoTo ScaleChange 'Skip downwards
End If
D6:
'This section takes primary TAKT time from cell D6 and formats right hand cell border. Range "LB4" named as 'SCALE'
'"I9:KZ9" named as 'GRADS', "I9:KZ60" named as 'CHART'
ScaleFactor = Range("SCALE").Value
If Range("C6").Value + Range("D6").Value = 0 Then
With Range("CHART").Borders(xlInsideVertical) 'Clear previous TAKT time by removing ALL vertical cell borders within range 'CHART'
.LineStyle = xlLineStyleNone
End With
With Range("GRADS") 'Clear borders from 'GRADS' range
.Borders.LineStyle = xlLineStyleNone
.Interior.ColorIndex = 24
End With
GoTo ScaleChange 'Skip downwards
End If
If Range("C6").Value = 0 Or Range("C6").Value = "" Then
MsgBox "Use the RED box first", vbCritical, "Wrong box "
Range("D6").Value = ""
Range("C6").Select
Exit Sub
End If
If Range("D6").Value = "" Or Range("D6").Value = 0 Then
GoTo ScaleChange 'Skip downwards
End If
If Target.Address(0, 0) = "C6" Then
With Range("CHART").Borders(xlInsideVertical) 'Clear previous TAKT time by removing ALL vertical cell borders within range 'CHART'
.LineStyle = xlLineStyleNone
End With
With Range("GRADS")
.Borders.LineStyle = xlLineStyleNone 'Clear borders from 'GRADS' range
.Interior.ColorIndex = 24
End With
With Range(Cells(9, (Target * ScaleFactor) + 8), Cells(60, (Target * ScaleFactor) + 8)).Borders(xlEdgeRight)
.LineStyle = xlContinuous ' Add new TAKT time indicator line
.Weight = xlThick
.ColorIndex = 3
End With
End If
If Target.Address(0, 0) = "D6" Then
With Range(Cells(9, (Target * ScaleFactor) + 8), Cells(60, (Target * ScaleFactor) + 8)).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
End If[/COLOR]
ScaleChange:
Application.ScreenUpdating = False
'Create graduations in row I. Range "I9:FD9" = 'GRADS'
With Range("GRADS")
.Borders.LineStyle = xlLineStyleNone
.Interior.ColorIndex = 24
End With
Range("I9").Select
Do Until ActiveCell.Value = 304
If (ActiveCell.Value / Range("SCALE").Value) - (Int(ActiveCell.Value / Range("SCALE").Value)) = 0 Then
With ActiveCell
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlEdgeRight).ColorIndex = 1
End With
End If
ActiveCell.Offset(0, 1).Select
Loop
'This section selects and deletes ALL labels in range("Labels") prior to updating with new graduations
Dim aName As String
Dim myDocument As Worksheet
Dim shp As Shape
Dim check As Integer
aName = ActiveSheet.Name
Set myDocument = ActiveSheet
For Each shp In myDocument.Shapes
If Not Intersect(myDocument.Range("Labels"), shp.TopLeftCell) Is Nothing And _
Not Intersect(myDocument.Range("Labels"), shp.BottomRightCell) Is Nothing Then
shp.Delete
End If
Next shp
'This section places labels on each of the graduations created above
Range("I8").Select
Do Until ActiveCell.Value = 304
LabelValue = ActiveCell.Value / Range("SCALE").Value
ShapeName = ActiveCell.Value / Range("SCALE").Value
If (ActiveCell.Value / Range("SCALE").Value) - (Int(ActiveCell.Value / Range("SCALE").Value)) = 0 Then
PutLabel "A label", ActiveCell, 10
End If
ActiveCell.Offset(0, 1).Select
Loop
'Return to last working cell and tidy border on last cell
Range("KZ9").Select
With ActiveCell
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 1
End With
Application.ScreenUpdating = True
End Sub
Sub PutLabel(strLbl As String, rngLocation As Range, wdth As Long)
Dim txt As Shape
Dim tf As TextFrame
Set txt = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Left:=rngLocation.Left, Top:=rngLocation.Top, Width:=15, Height:=40)
With txt
.Fill.ForeColor.RGB = RGB(204, 204, 255)
.Line.ForeColor.RGB = RGB(204, 204, 255)
.Name = "Rectangle" & ShapeName
Set tf = .TextFrame
With tf
tf.Characters.Text = LabelValue
.AutoSize = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Characters.Font.Name = "Tahoma"
.Characters.Font.Size = 30
.Characters.Font.ColorIndex = 1
End With
End With
End Sub