Forum Discussion
Find if range has pictures [Solved with ongoing improvements?]
I have to find if each cell in a range has a picture in it.
I have the script below running in VB and need to figure out how to make it work for a range of cells.
Function HASpic(Cell As Range) As Boolean
' Yields TRUE if the cell identified by row and col contains a picture,
' otherwise FALSE
Dim Caddress As String
Dim Pict As Object
Application.Volatile
Caddress = Cell.Address
For Each Pict In Application.Caller.Parent.Pictures
If Pict.TopLeftCell.Address = Caddress Then
HASpic = True
Exit Function
End If
Next Pict
HASpic = False
End Function
The code works great but I need it to cycle through all of the cells in a dynamic range. some thing like the pic below.
I tried using the code below to call to the first script, but that didn't work. any suggestion?
Sub HASpicR(x As Range)
' Yields TRUE if the cell identified by row and col contains a picture,
' otherwise FALSE
Dim Caddress As String
Dim Pict As Object
For Each Cell In x
HASpic (Cell)
Next Cell
End Sub
Solution:
Edit HASpic function to accept a string for the cell address and run it using a BYROW formula.
Formula:
=BYROW(B4#,LAMBDA(array,HASpic(ADDRESS(ROW(array),COLUMN(array)))))
Function:
Function HASpic(Caddress As String) As Boolean
' Yields TRUE if the cell identified by row and col contains a picture,
' otherwise FALSE
Dim Pict As Object
Application.Volatile
For Each Pict In Application.Caller.Parent.Pictures
If Pict.TopLeftCell.Address = Caddress Then
HASpic = True
Exit Function
End If
Next Pict
HASpic = False
End Function
This is probably not the most elegant solution. But! It works... So, I'll take it!
Jagodragon good point. this should address that issue (i.e. search for pictures on the same sheet as the range your select)
Function HASpicR(x As Range) As Variant ' Yields TRUE if the cell identified by row and col contains a picture, ' otherwise FALSE Application.Volatile Dim p As Range Dim r, c As Long Dim s() As Variant r = x.Rows.Count c = x.Columns.Count ReDim s(1 To r, 1 To c) For Each Pict In x.Parent.Pictures Set p = Pict.TopLeftCell If Not Intersect(p, x) Is Nothing Then s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True End If Next Pict HASpicR = s End Function
Option Explicit Public Function IsOne(val As Variant) As Boolean IsOne = False If val = 1 Then IsOne = True End If End Function Public Function IsOneRange(rng As Range) As Variant Dim output() As Boolean Dim i As Integer ReDim output(1 To rng.Rows.Count) For i = 1 To rng.Rows.Count output(i) = IsOne(rng.Cells(i, 1)) Next i IsOneRange = Application.WorksheetFunction.Transpose(output) End FunctionTo return an array, you must build it in the function. My example above uses a simple "IsOne" instead of "HasPic", but I think you will see the idea.
Let me know if it works.
flexyourdata This worked great when combined with the change to make HASpic accept the an address(see edit in main post)! THANK YOU!
Function HASpicR(x As Range) As Variant Dim output() Dim i As Integer ReDim output(1 To x.Rows.Count) For i = 1 To x.Rows.Count output(i) = HASpic(x.Cells(i, 1).Address) Next i HASpicR = Application.WorksheetFunction.Transpose(output) End FunctionJagodragon I see you already have your solution but I will submit this because your solution has a few drawbacks. a) it is only for a single column b) it is looping through every picture for every cell in the range you are interested in. so if you have 100 pictures over 300 lines that means 30,000 checks. I reworked the original function to assign a TRUE value if it is in the range. I didn't initialize the whole array to FALSE so the output is 0 or True instead of T/F. But it only loops the pictures 1x and can handle multiple columns.
Function HASpicR(x As Range) As Variant ' Yields TRUE if the cell identified by row and col contains a picture, ' otherwise FALSE Application.Volatile Dim sourceCell, spillRange, p As Range Dim r, c As Long Dim s() As Variant r = x.Rows.Count c = x.Columns.Count ReDim s(1 To r, 1 To c) For Each Pict In Application.Caller.Parent.Pictures Set p = Pict.TopLeftCell If Intersect(p, x).Count Then s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True End If Next Pict HASpicR = s End FunctionI'm guessing you don't need it but since I did it (more for my own satisfaction) i thought I would post it.
It doesn't work because it doesn't loop through the range or because you haven't assigned the T/F to anything? I would have expected something like:
HASpicR = FALSE
For Each Cell In x
HASpicR = HASpicR OR HASpic (Cell))
Next CellEDIT: and noticed that HASpicR would also need to be a FUNCTION of boolean type like the original HASpic function
- This didn't get me there. but thank you. I'm Editing the main post to contain the solution right now.
- Thank you. It is looping now. but it is still only giving me one value. it is not populating a range.
