Using Pictures to return numeric totals

[matt3542]

Dear Forum Members,

I am trying to achieve something rather abstract using VBA code and I'm not
entirely sure if its possible, hence any help would be greatly appreciated.
Instead of using numeric values in cells I have represented some data
pictorially (by pasting various .jpg's on top of cells) and would like to
use a command button to determine the total number of times the picture
occurs for a given employee and display the results in cells B18:H18*

Jbloggs1 Pic1(B5) Pic2(C5) Pic3(D5) Pic4(E5) Pic5(F5)..to Pic7(K5)

CmdBtnJbloggs1 *TotalPic1 TotalPic2 TotalPic3 TotalPic4...

There are 7 pics that can appear in any order/frequency up to a maximum of
10 times on top of cells B5:K5. I have also changed the name of the pics to
those given above. Does anyone know if this is possible? Any help would be
fantastic, Many thanks, Matt

 

[Peter T]

What do you mean by pictures can appear in any frequency. Whilst there may
be several copies of a particular picture on a sheet, each name will be
different, which means they are in effect different pictures which happen to
look the same. (There is an almost accidental way to have pictures with
duplicate names but that only follows a certain scenario.

You could perhaps name similar pictures something like
PicA_001.pic, PicA_002.pic
then you'd know that pictures with prefix "PicA_" are equivalent pictures

Secondly, pictures do not "belong" to cells though top-left & bottom-right
cell locations are easily returned. If for your idea to have any chance of
working you'd need to be sure that say a picture's top-left corner really is
located within your cell, not say slightly above or to the left. Easy for a
picture to get nudged slightly off the cell you think it's in.

Subject to clarifying the above, something along the lines of what you are
asking might be possible. Have you considered working with one of the
various picture type fonts which might lead to an equivalent solution much
more easily (just type in a letter), quickly (in terms of processing) and
not least reliably (no ambiguity about which character(s) exist in which
cells).

Regards,
Peter T

 

[matt3542]

Hi Peter, apologies for the confusion, perhaps frequency was the wrong way of
referencing what I meant. There are 10 cells for any given employee entity
with 7 possible pictures (obviously some will appear more than once) and all
the pictures have been given a unique name via the name box. Before pasting
the pictures into the cells I made sure each cell was selected and I have not
re-positioned manually. Admittedly I had not thought of using the picture
type fonts because the type of pictures I have used have a relevance to what
is being conveyed. I hope this clarifies things a little better, hope to hear
back from you. Thanks, Matt

 

[Peter T]

So you have 7 possible pictures, some may appear more than once, each has a
unique name. I'm still confused.

I have all sorts of guesses as to what you might mean but could you have
another go at clarifying

Regards,
Peter T

 

[Andy Pope]

Hi,

Although you need to have unique names for the pictures you will need to
keep some part of the name consistent in order to count duplicates of the
same picture.
Let's assume the pictures are about the type of pets a person has. Available
choices are Dog, Cat, Fish or Bird.
You would need 10 Dog pictures named "Dog1", "Dog2", "Dog3"..... "Dog10"
10 Cat pictures named "Cat1","Cat2"..."Cat10"
hopefully you get the idea.

Now you can identify the type of picture from it's name. And depending on
how the pictures are being displayed on the sheet the number of each type.

The other bit of information you may need if the TopLeftCell property of the
picture in order to locate it's position on the worksheet.

Cheers
Andy

 

[matt3542]

Thank you for your patience Peter,

I have a list of employee names in ColA and each employee row has 10 icon
size pictures to the right of the employee name placed on top of 10
respective cells. There are 7 possible pictures linked to a key which
explains what each represent. Each picture has been given a unique name in
the white Picture Name box in the upper left corner of the worksheet so there
are 7 Picture names from Pic1 to Pic7

For ease of use lets say - Employee A (A1) Has 10 Pic1's placed on top
of adj cells

Under the list of employee names I have a command button for each employee.
When a user clicks the button I would like cells to the left to populate with
the totals for the number of times each picture appears in the table above.
There should be 7 individual totals that combined total 10. In the above e.g
it would return 10 0 0 0 0 0 0 in 7 seperate cells to the left of the button.

I'm really sorry if you still do not follow, it must be hard for you to
understand what I'm trying to convey without seeing the datasheet, shame I
can't send you a copy?! Any thoughts, even if its to suggest scapping the
idea would be most welcome! Thanks, Matt

 

[Peter T]

I had understood almost everything below but still stuck on the same thing
since the beginning -

For ease of use lets say - Employee A (A1) Has 10 Pic1's placed on top
of adj cells

What is the unique name for each of your 10 Pic1's

Have you named them along the lines of Andy's example of Dog1, Dog2 etc or
my similar example of PicA_001, PicA_002 etc.

Regards,
Peter T

 

[matt3542]

Hi Peter,

I had not given them unique names I had given each picture the same name,
i.e All dogs named Dog1, all cats named Cat1..Does this help?

 

[Peter T]

That was one of my guesses early on, pictures with duplicate names (not
unique!). Although it's easy enough to name multiple objects with duplicate
names with code I'm curious as to how you did that manually. If I do try and
do that in the names box, entering a duplicate name selects the object that
already has that name. Oh well, somehow you did it. Have a go with the
following.

As written should fill I2:O20 with totals of your pictures named Pic1,
Pic2..Pic7 that exist anywhere in each of the 19 rows B2:H20 on a per row
basis.

Sub CountPics()
Dim i As Long, n As Long
Dim rw0 As Long
Dim rng As Range, rTL As Range
Dim pic As Picture, pics As Pictures

With Range("h1")
For i = 1 To 7
.Offset(, i) = "Pic" & i
Next
End With

Set rng = Range("B2:H20")
rw0 = rng.Row - 1

ReDim picCnt(1 To rng.Rows.Count, 1 To 7)

Set pics = ActiveSheet.Pictures

For i = 1 To pics.Count
With pics(i)
If .Name Like "Pic#" Then
n = 0
n = Val(Mid(.Name, 4, 1))
If n Then
Set rTL = .TopLeftCell
If Not Intersect(rng, rTL) Is Nothing Then
picCnt(rTL.Row - rw0, n) = picCnt(rTL.Row - rw0, n) + 1
End If
End If
End If
End With
Next

rng.Offset(, rng.Columns.Count).Resize(, 7).Value = picCnt
End Sub

Regards,
Peter T

 

[Peter T]

Although it's easy enough to name multiple objects with duplicate names
with code I'm curious as to how you did that manually.

Ok I get it now, when an object that has been renamed from its default is
copied, the pasted object retains the name, hence duplicate named objects
are easily created. I should have known that.

Peter T

 

[matt3542]

Good morning Peter, apologies for the delay replying I've just returned to
work. Once again I just wanted to thankyou for your perseverence and time you
have taken helping a lowly novice like myself. The code worked perfectly,
many, many thanks! Matt

 

[matt3542]

Hi Peter,

Sorry to intrude on you again, just a quick question if I may..the range of
cells that have pictures on top of them is B2:K9 (to allow for 8 employees,
each having 10 pictures I thought it would be a simple case of changing the
range (> Set rng = Range("B2:K9")) but the code does not run as before, can
you please let me know where I am going wrong? Many thanks, matt

 

[Peter T]

Yes, all you should need to do is changeto
Set rng = Range("B2:K9")

and one more thing, I threw following in as an optional extra as picture
name headers

either delete it altogether or changeto
With Range("K1")

Another minor thing entirely up to you, if you want totals that = zero to
appear as 0 changeto
ReDim picCnt(1 To rng.Rows.Count, 1 To 7) as Long

but if you want zeros as blanks leave it as is

Regards,
Peter T

 

[matt3542]

Hi Peter, Good to hear back from you, I've tried doing exactly that but its
returning "run-time error'9': Subscript out of range" When I try and debug it
jumps straight to the line of code below;

picCnt(rTL.Row - rw0, n) = picCnt(rTL.Row - rw0, n) + 1

Strangely it works when if I change the row range, i.e from H20 to H30 but
it doesn't run when the column range is changed, any thoughts? Also I did
notice your additional tweaks, I found them most helpful, clever stuff! I did
want to display zero's so thanks for the customised code to enable me to do
that. Many thanks, matt

 

[Peter T]

Only thing I can think of is if you have any pictures named Pic8 or more, 8+
would exceed the columns dimensioned in the array and give the error you
mentioned

Replace the previous example with the following, and change the two lines as
indicated to suit

Sub CountPics()
Dim i As Long, n As Long, nCols As Long
Dim rw0 As Long
Dim rng As Range, rTL As Range
Dim pic As Picture, pics As Rectangles

Set rng = Range("B2:k20") ' << Change
nCols = 8 ' << Pic1 to PicX, change to suit X

rw0 = rng.Row - 1

With rng(rng.Rows(1).Cells.Count).Offset(-1, 0)
For i = 1 To nCols
.Offset(, i) = "Pic" & i
Next
End With

ReDim picCnt(1 To rng.Rows.Count, 1 To nCols) As Long

Set pics = ActiveSheet.Rectangles

For i = 1 To pics.Count
With pics(i)
If .Name Like "Pic#" Or .Name Like "Pic##" Then
n = 0
n = Val(Mid(.Name, 4, 2))
If n Then
Set rTL = .TopLeftCell
If Not Intersect(rng, rTL) Is Nothing Then
picCnt(rTL.Row - rw0, n) = picCnt(rTL.Row - rw0, n) + 1
End If
End If
End If
End With
Next

rng.Offset(, rng.Columns.Count).Resize(, nCols).Value = picCnt
End Sub

Regards,
Peter T

 

[Peter T]

Oops, replace "Rectangles" twice with "Pictures"

(I used the former in my testing, ie small rectangles from the drawing
toolbar, renamed to Pic1 Pic2 etc, copied multiple times and placed in the
range)

Peter T

Only thing I can think of is if you have any pictures named Pic8 or more,
8+ would exceed the columns dimensioned in the array and give the error
you mentioned

Replace the previous example with the following, and change the two lines
as indicated to suit

Sub CountPics()
Dim i As Long, n As Long, nCols As Long
Dim rw0 As Long
Dim rng As Range, rTL As Range
Dim pic As Picture, pics As Rectangles

Set rng = Range("B2:k20") ' << Change
nCols = 8 ' << Pic1 to PicX, change to suit X

rw0 = rng.Row - 1

With rng(rng.Rows(1).Cells.Count).Offset(-1, 0)
For i = 1 To nCols
.Offset(, i) = "Pic" & i
Next
End With

ReDim picCnt(1 To rng.Rows.Count, 1 To nCols) As Long

Set pics = ActiveSheet.Rectangles

For i = 1 To pics.Count
With pics(i)
If .Name Like "Pic#" Or .Name Like "Pic##" Then
n = 0
n = Val(Mid(.Name, 4, 2))
If n Then
Set rTL = .TopLeftCell
If Not Intersect(rng, rTL) Is Nothing Then
picCnt(rTL.Row - rw0, n) = picCnt(rTL.Row - rw0, n) + 1
End If
End If
End If
End With
Next

rng.Offset(, rng.Columns.Count).Resize(, nCols).Value = picCnt
End Sub

Regards,
Peter T

<snip>

 

[matt3542]

Hi Peter, the amended code worked beautifully, I'm really grateful for the
time you have devoted helping me find a solution, it has provided me with a
really solid application that is fit for purpose.

Best wishes (Ps I don't work weekends so I've only just picked this up,
wasn't beinig ignorant or deliberately slow replying)

Take care, matt

 

[Peter T]

You're welcome, glad it works

Regards,
Peter T

Hi Peter, the amended code worked beautifully, I'm really grateful for the
time you have devoted helping me find a solution, it has provided me with
a
really solid application that is fit for purpose.

Best wishes (Ps I don't work weekends so I've only just picked this up,
wasn't beinig ignorant or deliberately slow replying)

Take care, matt

<snip>