VBA to format cell borders based on cell value

[picklefactory]

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

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

 

[Snakehips]

plicklefactory,

Unless there is something here that I cannot fully appreciate, then I think that you can greatly simplify the 'indicator line' section of your code as follows...

Replace the red text of your original code with code below.

ChangeIndicators:  
ScaleFactor = Range("SCALE").Value
 
'Set values of C6 & D6 to variables etc ****Declare the variables first, below, if that is your policy
 
BlueCol = Range("D6").Value
If BlueCol = "" Then BlueCol = 0
RedCol = Range("C6").Value
If RedCol = "" Then RedCol = 0
 
        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
 
If RedCol = 0 Then GoTo Blue  'Skip if C6 = 0 or ""
 
         'Otherwise red border col number as per C6
    With Range(Cells(9, (RedCol * ScaleFactor) + 8), Cells(60, (RedCol * ScaleFactor) + 8)).Borders(xlEdgeRight)
            .LineStyle = xlContinuous ' Add new TAKT time indicator line
            .Weight = xlThick
            .ColorIndex = 3
        End With
Blue:
     If BlueCol = 0 Then GoTo Out   'Skip if D6 = 0 or ""
 
        'Otherwise blue border col number as per D6
        With Range(Cells(9, (BlueCol * ScaleFactor) + 8), Cells(60, (BlueCol * ScaleFactor) + 8)).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .ColorIndex = 5
         End With

Also, and again provided that I am not missing the proverbial 'Monty Python' obvious....
Can you not just check if either C6 or D6 are the Target cell by replacing

 '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

With

'Check if TAKT time indicators need changing
If Intersect(Target, Range("C6")) Is Nothing And Intersect(Target, Range("D6")) Is Nothing Then Exit Sub
Goto ChangeIndicators

If the answer is yes then you can simplify other elements of your code in a similar way.


Sadly, I am master of the typo so fingers crossed that there are none in my revised code.

Preaze let mi knuw iv thqt holps.

Bad idea!! Typing with fingers crossed is even more difficult!!

 

[picklefactory]

Snakehips

Superb, thank you very much indeed. Only found one tiny bug (Goto Out, with Out: not defined) otherwise works like a charm. I've been beating my head against the wall with that for weeks.
Sorry for the delay in getting into it, but I only just sobered up enough over the hols to be able to understand what you did.
Thanks again for your time and trouble and hope you have had/are having a great Christmas. The help you guys give on this site is invaluable for us amateurs and greatly appreciated.
Cheers

 

[Snakehips]

picklefactory,

You are welcome.
Sorry about the Goto Out. That was a remnant of my testing where I wanted to control the exit.
I assume that you have now taken that out in favour of Goto Pub?

 

[picklefactory]

If only there was a decent pub where I live!!