Draw line in a specific cell and change font color

imageicb

Board Regular
Joined
Jan 13, 2012
Messages
66
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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

Gary's Student

Well-known Member
Joined
Aug 4, 2012
Messages
1,015
This code should place the line and "whiten" the text:

Code:
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

Board Regular
Joined
Jan 13, 2012
Messages
66
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

Well-known Member
Joined
Aug 4, 2012
Messages
1,015
You could call test2 in a loop:

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

p45cal

Well-known Member
Joined
Nov 10, 2009
Messages
4,763

ADVERTISEMENT

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:
Code:
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
 
Last edited:

imageicb

Board Regular
Joined
Jan 13, 2012
Messages
66
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

Well-known Member
Joined
Aug 4, 2012
Messages
1,015

ADVERTISEMENT

p45cal:

Thanks for the help!
 

p45cal

Well-known Member
Joined
Nov 10, 2009
Messages
4,763
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:
Code:
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:
Code:
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

Board Regular
Joined
Jan 13, 2012
Messages
66
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

Well-known Member
Joined
Nov 10, 2009
Messages
4,763
I tested this in Excel 2003 and 2010, no error. On what line does the error occur?
 

Watch MrExcel Video

Forum statistics

Threads
1,130,310
Messages
5,641,450
Members
417,210
Latest member
rins

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top