Make the macro display the cell addresses affected.

Hello!

I tried to modify this to get the AffectedCell.Address displayed in the msgbox, but only succeed in getting the ActiveCell.Address (and just "cell" doesn't work). What else do I need to add to this?

Sub ListObjects()
    Dim objCount As Integer
    Dim x As Integer
    Dim objList As String
    Dim objPlural As String
    Dim objType(17) As String

    'Set types for different objects
    objType(1) = "Autoshape"
    objType(2) = "Callout"
    objType(3) = "Chart"
    objType(4) = "Comment"
    objType(7) = "EmbeddedOLEObject"
    objType(8) = "FormControl"
    objType(5) = "Freeform"
    objType(6) = "Group"
    objType(9) = "Line"
    objType(10) = "LinkedOLEObject"
    objType(11) = "LinkedPicture"
    objType(12) = "OLEControlObject"
    objType(13) = "Picture"
    objType(14) = "Placeholder"
    objType(15) = "TextEffect"
    objType(17) = "TextBox"

    objList = ""

    'Get the number of objects
    objCount = ActiveSheet.Shapes.Count

    If objCount = 0 Then
        objList = "There are no shapes on " & _
          ActiveSheet.Name
    Else
        objPlural = IIf(objCount = 1, "", "s")
        objList = "There are " & Format(objCount, "0") _
          & " Shape" & objPlural & " on " & _
          ActiveSheet.Name & vbCrLf & vbCrLf
        For x = 1 To objCount
            objList = objList & ActiveSheet.Shapes(x).Name & " at " & ActiveCell.Address & " is a " & IIf(ActiveSheet.Shapes(x).Visible = msoFalse, "Not Visible", "Visible") & " " & objType(ActiveSheet.Shapes(x).Type) & vbCrLf
        Next x
    End If

    MsgBox (objList)

End Sub

Thanks for your help!

VR/Lost

Public Sub DemoObjectLoop()
  Dim oShape As Shape
  Dim objDescr As String
  
  For Each oShape In ActiveSheet.Shapes
    
     objName = oShape.Name
     objAddr = oShape.BottomRightCell.Address
     objType = oShape.Type
     
      If oShape.Visible Then
        objVis = "Visible"
        Else
         objVis = "Not Visible"
      End If
      
     objDescr = objName & " at " & objAddr & " is a " & objVis & " " & objType & vbCrLf
     objList = objList & objDescr
  Next oShape
  
   MsgBox objList
End Sub

Nimrod,

You are taking this to a whole 'nother level.... Your code gets smaller and smaller each time.

a) The version I posted has the text of what each object is (Textbox, comment, etc.) which I like. (Yours just lists it as a "4" or "6".)

b) I couldn't get the 2nd version to work. 1004 Error on "objList=..." (This is with Excel 2003, so that may be why.)


MarvinP: What you are saying is what my question was about . My macro is great in that it shows that the object exists. But it doesn't list where the object is. That is what I was trying to add. I know that ActiveCell.Address wasn't right, but I didn't know what to put in its place to list the specific cell where that object is.

Thanks all!

VR/Lost

Hi Leaning:

The demo does , however , give you what you wanted ... it shows you how to get the objects position on the page. i.e. .BottomRightCell.Address . There is also another property call TopLeftCell.Address.

so in your code it would be ActiveSheet.Shapes(x).BottomRightCell.Address

Cheers

This solution shows the name of the type instead of typeCode.

Public Sub DemoObjectLoop()
  Dim oB As Shape
  Dim objDescr As String
  
  
  For Each oB In ActiveSheet.Shapes
    
     objName = oB.Name
     objAddr = oB.BottomRightCell.Address
     objType = TypeName(oB.OLEFormat.Object) 
     
    
      If oB.Visible Then
        objVis = "Visible"
        Else
         objVis = "Not Visible"
      End If
      
     objDescr = objName & " at " & objAddr & " is a " & objVis & " " & objType & vbCrLf
     objList = objList & objDescr
  Next oB
   
   If Len(objList) = 0 Then
      MsgBox "There are no shapes on " & ActiveSheet.Name
   Else
      MsgBox objList
   End If
   
   
End Sub