Draw 'X' (Diagonal lines) within selected cells and set line color

[Gary_M]

Modifications made to original code found at

Line through selected cells

I would like to draw a diagonal line from the lower left corner to the upper right corner of a selected group of cells. I am not talking about a diagonal line through all the cells in my selection, I am talking about a line drawn across the entire selection. The user may select range("A25:E32)...

www.mrexcel.com

Syntax: expression.AddLine (BeginX, BeginY, EndX, EndY)
Function AddConnector(Type As MsoConnectorType, BeginX As Single, BeginY As Single, EndX As Single, EndY As Single)

[FONT=courier new]============================================================================
Option Explicit

Sub Draw_X()
'This will draw an 'X' within the area of selected cells
    ' Line 1     from the top left of the top left cell
    '            to the bottom right of the bottom right cell of the selected range.
    ' Line 2     from the bottom left of the bottom left cell
    '            to the top right of the top right cell of selected cells.
    ' Selected cells must be contiguous

Dim rng As Range
Dim rngBtmRight As Range
Dim rngTopLeft As Range
Dim rngBtmLeft As Range
Dim rngTopRight As Range
Dim line1 As Shape, line2 As Shape
Dim line1Name, line2Name

    Set rng = Selection
    With rng
        ' Line 1
        Set rngTopLeft = .Cells(1, 1)
        Set rngBtmRight = .Cells(.Rows.Count + 1, .Columns.Count + 1)
        ' Line 2
        Set rngBtmLeft = .Cells(.Rows.Count + 1, 1)
        Set rngTopRight = .Cells(1, .Columns.Count + 1)
    End With
           
    '    Debug.Print "rngTopLeft - " & rngTopLeft.Address
    '    Debug.Print "rngBtmRight - " & rngBtmRight.Address
    '    Debug.Print "rngTopRight - " & rngTopRight.Address
    '    Debug.Print "rngBtmLeft - " & rngBtmLeft.Address

    Set line1 = rng.Parent.Shapes.AddConnector(msoConnectorStraight, _
                        rngTopLeft.Left, rngTopLeft.Top, _
                        rngBtmRight.Left, rngBtmRight.Top)
    Set line2 = rng.Parent.Shapes.AddConnector(msoConnectorStraight, _
                        rngBtmLeft.Left, rngBtmLeft.Top, _
                        rngTopRight.Left, rngTopRight.Top)
                        
    line1Name = line1.Name
    line2Name = line2.Name
    
    '    Debug.Print "Line 1: " & line1Name
    '    Debug.Print "Line 2: " & line2Name
    
    ' Procedure to reset the color of the lines
    ' pass the line names as text
    Shape_Color line1Name, line2Name
    
    rngTopLeft.Select   ' select top left cell
    
End Sub
============================================================================
Sub Shape_Color(shape1, shape2)
    ' pass the line (shape) name (as text) for the diagonal lines
    Dim defaultColor
    Dim Color_Black, Color_Red
    Color_Black = RGB(0, 0, 0)  ' change as needed
    Color_Red = RGB(255, 0, 0)  ' change as needed
    
    ActiveSheet.Shapes.Range(Array(shape1)).Select
    With Selection.ShapeRange.line
        .Visible = msoTrue
        .ForeColor.RGB = Color_Black    ' change as needed
        .Transparency = 0
    End With
    ActiveSheet.Shapes.Range(Array(shape2)).Select
    With Selection.ShapeRange.line
        .Visible = msoTrue
        .ForeColor.RGB = Color_Black    ' change as needed
        .Transparency = 0
    End With

End Sub
============================================================================[/FONT]

 

[sxhall]

Hi Gary,

I had some code that did similar to this from something i worked on previously, have updated it a bit to give what you need to add a diagonal line from bottom left to top right of a selection. Also included a line to add in the other diagonal if you want a cross.

Sub InsertDiagonalLine()

Dim FRow As Long
Dim FCol As Long
Dim LRow As Long
Dim LCol As Long

Dim X As Integer
Dim Y As Integer
Dim A As Integer
Dim B As Integer

Set selectionRange = Selection

FRow = selectionRange.Cells(1, 1).Row
FCol = selectionRange.Cells(1, 1).Column
LRow = selectionRange.Cells(selectionRange.Rows.Count, 1).Row
LCol = selectionRange.Cells(1, selectionRange.Columns.Count).Column

Cells(LRow + 1, FCol).Select
With Selection
X = Selection.Left
Y = Selection.Top
End With

Cells(FRow, LCol + 1).Select

With Selection
A = Selection.Left
B = Selection.Top
End With

'Bottom left to top right
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, X, Y, A, B).Select

'Top left to bottom right if a cross is required
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, X, B, A, Y).Select 'delete this row if not required

Cells(LRow + 1, FCol).Activate

End Sub

Works on any size selection including a single cell, some random selections from my test.