Circle Invalid Data

[mdmackillop]

I'm looking to get the address of invalid cells for this question (http://www.vbaexpress.com/forum/showthread.php?56361-Macro-to-only-allow-data-to-be-copy-pasted-based-on-data-validation-criteria&p=344789&viewfull=1#post344789). I thought the following should give a cell address but I'm getting an error. Any ideas?


Sub Test()
Dim sh As Shape
ActiveSheet.CircleInvalid
For Each sh In ActiveSheet.Shapes
If Left(sh.Name, 4) = "Oval" Then
MsgBox sh.TopLeftCell.Address
End If
Next
End Sub

[Paul_Hossler]

Maybe Oval's don't have a TopLeftCell

Alternative way




Sub test2()
Dim c As Range
ActiveSheet.CircleInvalid

On Error GoTo NiceExit

MsgBox ActiveSheet.Cells.SpecialCells(xlCellTypeAllValidation).Address

For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeAllValidation)
If Not c.Validation.Value Then
MsgBox c.Address
End If
Next

NiceExit:
End Sub

[mdmackillop]

Hi Paul
I found that solution to the question. I'm assumed all Shapes would have a TopLeftCell.

[Paul_Hossler]

Manually Inserted Oval shapes do, but I guess InvalidData ovals don't

[snb]

Of course @PH's code is better, but I tried to use the shape properties:


Sub M_snb()
Sheet2.CircleInvalid

ReDim sn(1 To Sheet2.UsedRange.Rows.Count)
For j = 1 To UBound(sn)
sn(j) = Sheet2.UsedRange.Rows(j).Top
Next

ReDim sp(1 To Sheet2.UsedRange.Columns.Count)
For j = 1 To UBound(sp)
sp(j) = Sheet2.UsedRange.Columns(j).Left
Next

For Each sh In Sheet2.Shapes
If Left(sh.Name, 4) = "Oval" Then MsgBox Cells(Application.Match(sh.Top, sn, 1) + 1, Application.Match(sh.Left, sp, 1)).Address
Next
End Sub

[mdmackillop]

Hi SNB
I tried your code but got strange results. The Circles were not correctly mapped and 6 "extra" ovals were found. Running this on the posted workbook gives a count of 8 shapes, but only two visible.

Sub MD_snb()
For Each sh In Sheet2.Shapes
sh.Delete
Next sh
MsgBox Sheet2.Shapes.Count
Sheet2.CircleInvalid
MsgBox Sheet2.Shapes.Count

ReDim sn(1 To Sheet2.UsedRange.Rows.Count)
For j = 1 To UBound(sn)
sn(j) = Sheet2.UsedRange.Rows(j).Top
Next

ReDim sp(1 To Sheet2.UsedRange.Columns.Count)
For j = 1 To UBound(sp)
sp(j) = Sheet2.UsedRange.Columns(j).Left
Next

MsgBox Sheet2.Shapes.Count
For Each sh In Sheet2.Shapes
If Left(sh.Name, 4) = "Oval" Then msg = msg & sh.Name & " - " & Cells(Application.Match(sh.Top, sn, 1) + 1, Application.Match(sh.Left, sp, 1)).Address & vbCr
Next
MsgBox msg
End Sub

[Kenneth Hobs]

For the example workbook, snb's method is fine. It found 8 for Sheet2 as expected. It found 2 for the other sheet when I changed Sheet2 to ActiveSheet as expected.

Of course checking for "oval" may not be exact enough all the time. One may need to also check the shape's visible value.

Option Explicit

Sub MD_snb()
Dim sh As Shape, j As Long, sp() As Variant, sn() As Variant
Dim msg As String

For Each sh In ActiveSheet.Shapes
sh.Delete
Next sh

MsgBox ActiveSheet.Shapes.Count
ActiveSheet.CircleInvalid
MsgBox ActiveSheet.Shapes.Count

ReDim sn(1 To ActiveSheet.UsedRange.Rows.Count)
For j = 1 To UBound(sn)
sn(j) = ActiveSheet.UsedRange.Rows(j).Top
Next

ReDim sp(1 To ActiveSheet.UsedRange.Columns.Count)
For j = 1 To UBound(sp)
sp(j) = ActiveSheet.UsedRange.Columns(j).Left
Next

MsgBox ActiveSheet.Shapes.Count
msg = ""
For Each sh In ActiveSheet.Shapes
If Left(sh.Name, 4) = "Oval" Then _
msg = msg & sh.Name & " - " & Cells(Application.Match(sh.Top, sn, 1) + 1, _
Application.Match(sh.Left, sp, 1)).Address & vbCr
Next
MsgBox msg
End Sub

[mdmackillop]

OK, I was looking at the wrong sheet! (never noticed the Sheet2 in the code):blush

Thanks all.

[snb]

@KH

You are my hero !!

[Paul_Hossler]

Some things that might be issues

1. All shapes are deleted, and you might not want that

2. It's fast for just 11 rows and one column, but I'd expect it'd slow down if you had lots of data

3. A manually inserted oval shape ("Oval 3456") would generate a false positive

4. It might be safer to use



If sh.Type = msoAutoShape and sh.Visible = msoTrue Then

If sh.AutoShapeType = msoShapeOval Then




making the final (for now) result something like this



Option Explicit

Sub MD_snb()
Dim sh As Shape, j As Long, sp() As Variant, sn() As Variant
Dim msg As String

' For Each sh In ActiveSheet.Shapes
' sh.Delete
' Next sh

MsgBox ActiveSheet.Shapes.Count
ActiveSheet.CircleInvalid
MsgBox ActiveSheet.Shapes.Count

ReDim sn(1 To ActiveSheet.UsedRange.Rows.Count)
For j = 1 To UBound(sn)
sn(j) = ActiveSheet.UsedRange.Rows(j).Top
Next

ReDim sp(1 To ActiveSheet.UsedRange.Columns.Count)
For j = 1 To UBound(sp)
sp(j) = ActiveSheet.UsedRange.Columns(j).Left
Next

MsgBox ActiveSheet.Shapes.Count
msg = ""
For Each sh In ActiveSheet.Shapes
If sh.Type = msoAutoShape And sh.Visible = msoTrue Then
If sh.AutoShapeType = msoShapeOval Then
On Error Resume Next
If Not TypeOf sh.TopLeftCell Is Range Then
msg = msg & sh.Name & " - " & Cells(Application.Match(sh.Top, sn, 1) + 1, _
Application.Match(sh.Left, sp, 1)).Address & vbCr
End If
On Error GoTo 0
End If
End If
Next
MsgBox msg
End Sub



Personally, I still feel like it's a lot of looping and complication compared the approach in #2

[mdmackillop]

Hi Paul
Validation.Value fixed the problem. I was just curious as to the unusual properties of the Shape use by the command.

[Kenneth Hobs]

I guess that it depends on your goal. Technically, the shape method is correct. Note how B10's oval shape on the first sheet overlaps A10. So, its topleftcell is A10. We then get two shapes in A10. Practically, the validation method is correct. One"shape" in A10 and one in B10.

Fun stuff for sure...

[Paul_Hossler]

Personally, I think it's a bug. When they inserted ValidationCircles, they just forgot to update .TopLeftCell

[Kenneth Hobs]

Something is amiss, read buggy. They should not overlap in adjacent cells.

[snb]

@PH

I agree; my personal preference is definitely yours in #2