Draw line in a specific cell and change font color

[imageicb]

I have a button that when you click it it inserts a line via the below code:

Sub test()
ActiveSheet.Shapes.AddLine(100, 300#, 300, 300).Select
End Sub

How can I tell it to draw the line in a specific cell (AM13, P15,ect.). Also I would like it to turn the font of any data in the cells that ar lined out white.

Is it also possible that upon another click it will remove the line and return the font to black.

Any help would be great,

Thanks

 

[Gary's Student]

This code should place the line and "whiten" the text:

Sub test2()
p1 = ActiveCell.Left
p2 = ActiveCell.Offset(0, 1).Left
p3 = ActiveCell.Top
p4 = ActiveCell.Offset(1, 0).Top
pMID = (p3 + p4) / 2
ActiveSheet.Shapes.AddLine(p1, pMID, p2, pMID).Select
ActiveCell.Font.ColorIndex = 2
End Sub

The reverse code is similar.

 

[imageicb]

When I used your code it worked but only for the currently activated cell. So i defined all the cells I wanted to use and added the following:

Range("lineout").Select
p1 = ActiveCell.Left
p2 = ActiveCell.Offset(0, 1).Left
p3 = ActiveCell.Top
p4 = ActiveCell.Offset(1, 0).Top
pMID = (p3 + p4) / 2
ActiveSheet.Shapes.AddLine(p1, pMID, p2, pMID).Select
Range("lineout").Font.ColorIndex = 2
End Sub

However when I use this it will only lineout the first cell in the range not all of them. Is there a way to get it to lineout all of them.

THank You

 

[Gary's Student]

You could call test2 in a loop:

Sub MAIN()
Dim r As Range
For Each r In Range("lineout")
    r.Select
    Call test2
Next r
End Sub

 

[p45cal]

There's a potential gotcha with Gary's Student's code using offset, which might fall over when a cell which is either/or on the extreme right or bottom of the sheet (eg. if you selected an entire row). Instead, you can use the .height and .width properties of a cell:

Sub test2()
For Each cll In Selection.Cells
  p1 = cll.Left
  p2 = p1 + cll.Width
  pMid = cll.Top + cll.Height / 2
  ActiveSheet.Shapes.AddLine p1, pMid, p2, pMid
  cll.Font.ColorIndex = 2
Next cll
End Sub

 

[imageicb]

Thanks Gary's Studen and p45cal. It worked like a charm. Now is there a way I can reverse with another click of the button (remove lines, and turn text back black) or do I need to make another button to do that.

Thanks

 

[Gary's Student]

p45cal:

Thanks for the help!

 

[p45cal]

is there a way I can reverse with another click of the button (remove lines, and turn text back black) or do I need to make another button to do that.

It would be much easier/safer to create another button to do that. First a slight amendment to the first sub to reduce the number of calculations required:

Sub test2()
For Each cll In Selection.Cells
  p1 = cll.Left
  pMid = cll.Top + cll.Height / 2
  ActiveSheet.Shapes.AddLine p1, pMid, p1 + cll.Width, pMid
  cll.Font.ColorIndex = 2
Next cll
End Sub

, then the code for the second button:

Sub test3()
For Each cll In Selection.Cells
  cll.Font.ColorIndex = xlAutomatic
  For Each shp In ActiveSheet.Shapes
    If shp.Type = msoLine And shp.TopLeftCell.Address = cll.Address Then shp.Delete
  Next shp
Next cll
End Sub

(Again, this works on the selected cells)

 

[imageicb]

Ok this worked fine when the cells are empty but when I try to do it with text in any of the cells i get a 400 error when I run the delete button.

 

[p45cal]

I tested this in Excel 2003 and 2010, no error. On what line does the error occur?