VBA to insert Directional Arrows in Excel

[Chris Waller]

Hi All,

I am using Excel 2010 and I have been asked if it is possible to insert a block arrow on each row to indicate if the row has been moved up, down or has remained static. Currently the Spreasheet contains 64 rows of data and I know it may be possible to do this manually, however, before much longer this will be a daunting task. I would be grateful if someone could possibly help with any suggestions on how this could be done. The Block arrows need to be colourd Green if the row has moved up, Red if the row has moved down or a Black horizontal arro to signify if the row has remained static. TIA

 

[John_w]

I'm not sure if the idea behind this code will work for you. It relies on a column in the data (for example, column A) containing the original row number of every row of data. So with row 1 containing column headings and the first data row starting at row 2, cell A2 contains the number 2, A3 contains the number 3, A4 contains the number 4, etc. After you have moved any row(s), you run the macro and it will create or recreate block arrows in column A.

Public Sub Add_Row_Arrows()

    Dim shp As Shape, arrow As Shape
    Dim rowNumberCells As Range, rowNumberCell As Range
    Dim rowNumber As Long
    
    'Operate on the active sheet
    
    With ActiveSheet
        
        'Delete all current shapes (arrows)
        
        For Each shp In .Shapes
            shp.Delete
        Next
        
        'Create Range of all cells in column A starting at A2 to last populated cell in column A
        
        Set rowNumberCells = .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
        
        'Loop through the column A cells
        
        rowNumber = rowNumberCells.Row
        For Each rowNumberCell In rowNumberCells
            Select Case rowNumberCell.Value
                Case Is < rowNumber
                    Set arrow = .Shapes.AddShape(msoShapeDownArrow, rowNumberCell.Left + 2, rowNumberCell.Top, 18.6, 12.6) 'left, top, width, height
                    With arrow.Fill
                        .Visible = msoTrue
                        .ForeColor.RGB = RGB(255, 0, 0) 'red
                        .Transparency = 0
                        .Solid
                    End With
                Case Is > rowNumber
                    Set arrow = .Shapes.AddShape(msoShapeUpArrow, rowNumberCell.Left + 2, rowNumberCell.Top, 18.6, 12.6)
                    With arrow.Fill
                        .Visible = msoTrue
                        .ForeColor.RGB = RGB(0, 255, 0) 'green
                        .Transparency = 0
                        .Solid
                    End With
                Case Is = rowNumber
                    Set arrow = .Shapes.AddShape(msoShapeRightArrow, rowNumberCell.Left + 2, rowNumberCell.Top, 18.6, 12.6)
                    With arrow.Fill
                        .Visible = msoTrue
                        .ForeColor.RGB = RGB(0, 0, 0)   'black
                        .Transparency = 0
                        .Solid
                    End With
            End Select
            rowNumber = rowNumber + 1
        Next
        
    End With

End Sub

 

[Chris Waller]

John_w,

That appears to do the trick nicely. I will try your code at work tomorrow and I will keep you updated. Thanks once again.

 

[Chris Waller]

John_w,

I tried your VBA at work today and it worked a treat. Thanks for your help it is very much appreciated. Thanks Again.