VB code to check value in an object?

[Guest]

Hi all,

Trickey one for me as a novice, so hope you can help.

in my worksheets I have 4 rectangle boxes which have been drawn using the
drawing toolbar.

What I want is this..........

Below each box is a cell that holds a formula which will retun a specific £
value or be left blank, just for your info the formula held is

=IF(ISBLANK('1'!$E$14),"",'1'!$E$14)

For the 1st rectangle box the formula above is held in cell B9
for the 2nd rectangle box the formula above is held in cell D9
for the 3rd the formula is in cell F9
for the 4th the formula is in cell H9

so the code should check the value in each of the cells B9,D9,F9 and H9

Only one of these cells will ever be blank

so if B9 is blank I want the code to show the value of the rectangle box 53
to be displayed in sheet3 cell A2

if D9 is blank - value of rectangle box 54 to be displayed in sheet3 cell A2
if F9 is blank - value of rectangle box 9 to be displayed in sheet3 cell A2
or finaly
if H9 is blank - value of rectangle box 8 to be displayed in sheet3 cell A2

hope I have explained this ok, and can it be done ???

Many thanks in advance to you all

 

[Guest]

Assuming these are rectangles and not textboxes and the top left corner of
the rectangle is over the cells you listed:

Sub ABC()
Dim cell as Range, rc as Rectangle
With worksheets("Sheetname")
for each cell in Range("B9,D9,F9,H9")
if len(trim(cell)) = "" then
for rc in .Rectangles
if rc.TopLeftCell.Address = cell.Address then
worksheets("sheet3").Range("A2").Value = rc.Text
exit for
end if
Next
end if
Next
End With
End Sub

 

[Guest]

Tom,
thanks for ur reply, however the top left corner of the rectangle is NOT
over the cells listed.
The rectangle box is ABOVE the cell with the bottom of it just touching the
cell (and others),
can you change the code?
many thanks

 

[Guest]

Tom,
also I have just tried your code and there seems to be an error in this line

for rc in .Rectangles

as it is highlighted in red when I paste the code into the VB screen
any ideas?
thanks

 

[Guest]

I had a couple of other typos as well. See if this modification does it:

Change "Sheetname" to reflect the name of the sheet with the Ranges and
Rectangles.

Sub ABC()
Dim cell As Range, rc As Object
Dim rng As Range
With Worksheets("Sheetname")
For Each cell In .Range("B9,D9,F9,H9")
If Len(Trim(cell)) = 0 Then
For Each rc In .Rectangles
Set rng = .Range(rc.TopLeftCell, rc.BottomRightCell)
If Not Intersect(cell, rng) Is Nothing Then
Worksheets("sheet3").Range("A2").Value = rc.Text
Exit For
End If
Next
End If
Next
End With
End Sub

I tested this an it worked for me.

 

[Guest]

there were several typos in the original. See my latest post (code in that
post has been tested successfully).

 

[Guest]

Tom,
I cant get it to work, can I poss send you a sample worksheet to see exactly
what I want?
thanks again
Anthony

 

[Guest]

(e-mail address removed)

--
Regards,
Tom Ogilvy

Tom,
I cant get it to work, can I poss send you a sample worksheet to see exactly
what I want?
thanks again
Anthony