Visual Basic Autoshapes Macro

D

Dav

I am sure this is possible in a macro, but I'm only just learning them

In a workbook I have 2 sheets one containing last months data (lstmnth
and one containing this months data (thismnth)

On both sheets I wish to compare the ranges C1:L1, C5:L5, O1:X1, O5:x


All the cell values are numbers,

if the number on lstmnth is > this month I wish to insert a shap
MSoDownArrow possibly in the cell in thismnth

if the number on lstmnth is <this month I wish to insert a shap
MSoUpArrow possiblyin the cell in thismnth

So for example lstmnth!C1 is compared to Thismnth!C1 etc if lstmnth!C
is greater insert a down arrow in cell C1, this needs to repeat fo
each pair of cells in each of the ranges above. So repeated for D1 o
each sheet then E1 on each sheet etc


the shapes need to be transparent and centred horizontally an
verically in each cell.

If the macro could first delete any shapes already on the sheet tha
would also be great

thanks in advance for your hel
 
D

Dave Peterson

First, have you considered just using Format|conditional formatting to show the
differences.

Green or red would seem to be a nice indicator. And, for me, it would be much
easier to see.

But if you want, this seemed to work ok for me:

Option Explicit
Sub testme()
Dim myRng As Range
Dim myCell As Range
Dim CurWks As Worksheet
Dim LastWks As Worksheet
Dim myShape As Shape
Dim myType As Long

Set CurWks = Worksheets("thismnth")
Set LastWks = Worksheets("lstmnth")

With CurWks
Set myRng = .Range("C1:L1,C5:L5,O1:X1,O5:x5")
For Each myShape In .Shapes
If myShape.AutoShapeType = msoShapeUpArrow _
Or myShape.AutoShapeType = msoShapeDownArrow Then
If Intersect(myShape.TopLeftCell, myRng) Is Nothing Then
'do nothing
Else
myShape.Delete
End If
End If
Next myShape

For Each myCell In myRng.Cells
With myCell
myType = -999
If .Value < LastWks.Range(.Address).Value Then
myType = msoShapeDownArrow
ElseIf .Value > LastWks.Range(.Address).Value Then
myType = msoShapeUpArrow
End If

If myType > 0 Then
Set myShape = .Parent.Shapes.AddShape(myType, 0, 0, 0, 0)
myShape.Top = .Top
myShape.Height = .Height
myShape.Width = 24
myShape.Left = .Left + ((.Width - myShape.Width) / 2)
myShape.Fill.Visible = msoFalse
End If
End With
Next myCell
End With
End Sub


If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
 
D

Dav

Thanks Dave

That's Fantastic.
I use conditional formating based on the value of the current month
already, so am not able to use it for the change from last month.

The reason the symbols are used is to indicate whether the result has
improved or worsened from last month up or down & hence the arrow
 
Top