Visual Basic Autoshapes Macro

[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:x5

All the cell values are numbers,

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

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

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


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

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

thanks in advance for your help

[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



Dav wrote:
>
> 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:x5
>
> All the cell values are numbers,
>
> if the number on lstmnth is > this month I wish to insert a shape
> MSoDownArrow possibly in the cell in thismnth
>
> if the number on lstmnth is <this month I wish to insert a shape
> MSoUpArrow possiblyin the cell in thismnth
>
> So for example lstmnth!C1 is compared to Thismnth!C1 etc if lstmnth!C1
> is greater insert a down arrow in cell C1, this needs to repeat for
> each pair of cells in each of the ranges above. So repeated for D1 on
> each sheet then E1 on each sheet etc
>
> the shapes need to be transparent and centred horizontally and
> verically in each cell.
>
> If the macro could first delete any shapes already on the sheet that
> would also be great
>
> thanks in advance for your help
>
> --
> Dav
> ------------------------------------------------------------------------
> Dav's Profile: http://www.excelforum.com/member.php...o&userid=27107
> View this thread: http://www.excelforum.com/showthread...hreadid=493445

--

Dave Peterson

[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