how to put arrow shape inside cells using VBA - excel

Question

i'm working on a macro to generate comparison between numbers and i have the specific task to add some shapes near the text of every cell.
I tried to figure out how to calculate x, y, width, height in order to nicely place them in the cell, but without success.
I asked about that in a previous question and also obtaines a nice answer, but since i have a specific request i need the vba way to do this.
Any suggestions?
Dim s As Shape, sh As Worksheet
Set sh = ActiveSheet
If arrType = "Up" Then
Set s = sh.Shapes.AddShape(msoShapeUpArrow, x, y, width, height)
Else
Set s = sh.Shapes.AddShape(msoShapeDownArrow, x, y, width, height)
End If

Answer 1

Try the next adapted code, please. It happens I know your previous question on this theme, too:
Sub Compare_numbers()
Dim sh As Worksheet, i As Long, lastRow As Long
Dim arrA, txt As String
Set sh = ActiveSheet
lastRow = sh.cells(rows.count, "L").End(xlUp).row
For i = 2 To lastRow
If sh.cells(i, "L").Value = sh.cells(i, "M").Value Then
sh.cells(i, "N").Value = "they are equal"
arrA = isArrow(sh.Range("N" & i), "")
ElseIf sh.cells(i, "L").Value > sh.cells(i, "M").Value Then
With sh.cells(i, "N")
.Value = "L is greater than M ."
.EntireColumn.AutoFit
End With
arrA = isArrow(sh.Range("N" & i), "Up")
If arrA(0) = "OK" Then
If arrA(1) <> "Up" Then
insertArrow sh.Range("N" & i), "Up"
End If
Else
insertArrow sh.Range("N" & i), "Up"
End If
Else
With sh.cells(i, "N")
.Value = "L is greater than M ." 'Used this solution to Autofit on the larger text...
.EntireColumn.AutoFit
.Value = "L is less than M ."
End With
arrA = isArrow(sh.Range("N" & i), "Down")
If arrA(0) = "OK" Then
If arrA(1) <> "Down" Then
insertArrow sh.Range("N" & i), "Down"
End If
Else
insertArrow sh.Range("N" & i), "Down"
End If
End If
Next i
End Sub
It needs the following Sub inserting the appropriate arrow:
Sub insertArrow(rng As Range, arrType As String)
Dim sh As Worksheet, s As Shape
Dim leftP As Double, topP As Double, W As Double, H As Double
Set sh = rng.Parent
W = 8: H = 12 'set the arrow width and height (you can change them)
leftP = rng.left + rng.width - W - 1 'calculate the horiz position
topP = rng.top + (rng.height - H) / 2 'calculate the vert position
If arrType = "Up" Then
Set s = sh.Shapes.AddShape(msoShapeUpArrow, leftP, topP, W, H)
Else
Set s = sh.Shapes.AddShape(msoShapeDownArrow, leftP, topP, W, H)
End If
s.Name = s.Name & "-" & rng.Address 'add the cell address to be able
'to bring back the arrows moved by mistake
s.LockAspectRatio = msoFalse: s.placement = xlMoveAndSize
End Sub
And the next Function able to check if a shape is an arrow and what type:
Function isArrow(rng As Range, typeArr As String) As Variant
Dim s As Shape, sh As Worksheet, arr
Set sh = rng.Parent 'extract the range sheet where it belongs
For Each s In sh.Shapes
If s.TopLeftCell.Address = rng.Address Then 'match the range address with the shape TLCell address
If left(s.Name, 2) = typeArr Or left(s.Name, 4) = typeArr Then
isArrow = Array("OK", typeArr): Exit Function
Else
If left(s.Name, 2) = "UP" Or left(s.Name, 4) = "Down" Then
isArrow = Array("OK", IIf(typeArr = "Up", "Down", "Up"))
s.Delete: Exit Function
End If
Exit For
End If
End If
Next
isArrow = Array("No", "")
'the function creates an array able to 'tell' if the shape is an arrow and its type
End Function
Unfortunately, there is no event able to be triggered by the cell sizes change. But, try the next event, which act when you double click a cell. Please, copy it in the sheet code module, where you need to insert arrows:
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lastR As Long, s As Shape, i As Long, addr As String
'bring back the arrows moved by mistakes:
For Each s In Me.Shapes
If left(s.Name, 2) = "Up" Or left(s.Name, 4) = "Down" Then
addr = Split(s.Name, "-")(UBound(Split(s.Name, "-")))
If addr <> s.TopLeftCell.Address Then
s.left = Me.Range(addr).left + 10
s.top = Me.Range(addr).top + 1
End If
End If
Next
'last row on the column to be processed (N:N):
lastR = Me.Range("N" & Me.rows.count).End(xlUp).row
Me.Range("L:N").VerticalAlignment = xlCenter 'to look nicer
For i = 2 To lastR
arrangeSh Me.Range("N" & i)
Next i
End Sub
Sub arrangeSh(rng As Range)
Dim sh As Shape
For Each sh In rng.Parent.Shapes
If sh.TopLeftCell.Address = rng.Address Then
'bring back the row height if is less then the arrow height:
If rng.height < 12 Then rng.EntireRow.height = 12
sh.width = 8: sh.height = 12 'reset the arrow dimensions
'reposition the arrows:
sh.top = rng.top + (rng.height - sh.height) / 2
sh.left = rng.left + rng.width - sh.width - 1
Exit For
End If
Next
End Sub
It will firstly check if the arrow has been moved by mistake and bring it back on the 'mother' cell, then place it centered, at 1 point from the right cell side.
The event code can be placed in a sub, let us say reArrangeShapes, the event will have a single line reArrangeShapes, and this sub may be called from different sheet events (Calculate, Activate, Deactivate etc.). Doing its job when the events in discussion are triggered.
The subs can be optimized using Appliction.ScreenUpdating = True and Application.Calculation = xlCalculationManual at the beginning followed by Appliction.ScreenUpdating = True and and Application.Calculation = xlCalculationAutomatic at the end.
If something unclear, please, do not hesitate to ask for clarifications...
Edited:
In order to better understand what's happening the isArrow function can be tested using the next sub. You should select a cell (having or not an arrow and run the code:
Sub testIsArrow()
Debug.Print isArrow(ActiveCell, "Up")(0)
End Sub
What does it return in Immediate Window (being in IDE, press Ctrl + G)?
You must understand that if the active cell keeps an arrow not being "Up" type, the shape will be deleted...