is this possible - Randomly Generate Images into a range of cells

[rdimbleby82]

I am not sure if this is possible hence my question.

I want to have an excel spreadsheet which will have a word i.e. Cow in Cell A1 and in Cell B1 I want to have a picture of a cow, and repeat this for any number of words and images.


Then I want to be able to randomly produce 3 of these images next to each other elsewhere within the spreadsheet i.e.

(I'd really like to apply a button to allow for the random picture generation to be done by an end user)

Merged Cells A173: E173 - Random Image 1
Merged Cells F173: J173 - Random Image 2
Merged Cells K173: O173 - Random Image 3

The problem is that obviously Excel won't place an image in a single cell so what I have done for Words below will not work

=VLOOKUP(INT(RAND() * MAX(Sheet1!A:A))+1,Sheet1!A1:D$1303, 4, FALSE)

I have found support via the following link but I know little of VBA code so am unable to see how to get it to work for me.

http://www.contextures.com/excelfiles.html
DV0049 - ClipArt Selection

 

[Domenic]

Place the following macros in a regular module, and run the macro called 'DisplayRandomPics'. The macro can be assigned to a button.

<font face=Calibri><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br><br><SPAN style="color:#00007F">Sub</SPAN> DisplayRandomPics()<br><br>    <SPAN style="color:#00007F">Dim</SPAN> MergedAreas <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> MyPics() <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> PicsLoc <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> Temp1 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> Temp2 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> Pic <SPAN style="color:#00007F">As</SPAN> Picture<br>    <SPAN style="color:#00007F">Dim</SPAN> Cnt <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    PicsLoc = "B1:B170"  <SPAN style="color:#007F00">'Change the location of the pictures, accordingly</SPAN><br>    <br>    MergedAreas = Array("A173:E173", "F173:J173", "K173:O173")<br>    <br>    Cnt = 0<br>    Randomize<br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> Pic <SPAN style="color:#00007F">In</SPAN> ActiveSheet.Pictures<br>        <SPAN style="color:#00007F">If</SPAN> Union(Pic.TopLeftCell, Range(PicsLoc)).Address = Range(PicsLoc).Address <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">ReDim</SPAN> <SPAN style="color:#00007F">Preserve</SPAN> MyPics(0 <SPAN style="color:#00007F">To</SPAN> 1, 0 <SPAN style="color:#00007F">To</SPAN> Cnt)<br>            MyPics(0, Cnt) = Pic.Name<br>            MyPics(1, Cnt) = Rnd<br>            Cnt = Cnt + 1<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> Pic<br>    <br>    <SPAN style="color:#00007F">If</SPAN> Cnt < 3 <SPAN style="color:#00007F">Then</SPAN><br>        MsgBox "The range " & PicsLoc & " must contain at least 3 pictures...", vbExclamation<br>        <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br><br>    <SPAN style="color:#00007F">Call</SPAN> DeleteRandomPics<br>    <br>    <SPAN style="color:#00007F">For</SPAN> i = 0 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(MyPics, 2) - 1<br>        <SPAN style="color:#00007F">For</SPAN> j = i + 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(MyPics, 2)<br>            <SPAN style="color:#00007F">If</SPAN> MyPics(1, i) > MyPics(1, j) <SPAN style="color:#00007F">Then</SPAN><br>                Temp1 = MyPics(0, j)<br>                Temp2 = MyPics(1, j)<br>                MyPics(0, j) = MyPics(0, i)<br>                MyPics(1, j) = MyPics(1, i)<br>                MyPics(0, i) = Temp1<br>                MyPics(1, i) = Temp2<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN> j<br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    <br>    <SPAN style="color:#00007F">For</SPAN> i = 0 <SPAN style="color:#00007F">To</SPAN> 2<br>        ActiveSheet.Pictures(MyPics(0, i)).Copy<br>        Range(MergedAreas(i)).PasteSpecial<br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    <br>    Range("A1").Select<br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Sub</SPAN> DeleteRandomPics()<br><br>    <SPAN style="color:#00007F">Dim</SPAN> Pic <SPAN style="color:#00007F">As</SPAN> Picture<br><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> Pic <SPAN style="color:#00007F">In</SPAN> ActiveSheet.Pictures<br>        <SPAN style="color:#00007F">If</SPAN> Union(Pic.TopLeftCell, Range("A173:O173")).Address = Range("A173:O173").Address <SPAN style="color:#00007F">Then</SPAN><br>            Pic.Delete<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> Pic<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[Mr Kiwi Kerr]

I made an account just to say that you are a fantastic.
I have been scourging the Internets to figure out how to randomly generate pictures on excel. Credit to you!

Place the following macros in a regular module, and run the macro called 'DisplayRandomPics'. The macro can be assigned to a button.

Option Explicit

Sub DisplayRandomPics()

****Dim MergedAreas As Variant
****Dim MyPics() As String
****Dim PicsLoc As String
****Dim Temp1 As String
****Dim Temp2 As String
****Dim Pic As Picture
****Dim Cnt As Long
****Dim i As Long
****Dim j As Long
****
****PicsLoc = "B1:B170"**'Change the location of the pictures, accordingly
****
****MergedAreas = Array("A173:E173", "F173:J173", "K173:O173")
****
****Cnt = 0
****Randomize
****For Each Pic In ActiveSheet.Pictures
********If Union(Pic.TopLeftCell, Range(PicsLoc)).Address = Range(PicsLoc).Address Then
************ReDim Preserve MyPics(0 To 1, 0 To Cnt)
************MyPics(0, Cnt) = Pic.Name
************MyPics(1, Cnt) = Rnd
************Cnt = Cnt + 1
********End If
****Next Pic
****
****If Cnt < 3 Then
********MsgBox "The range " & PicsLoc & " must contain at least 3 pictures...", vbExclamation
********Exit Sub
****End If
****
****Application.ScreenUpdating = False

****Call DeleteRandomPics
****
****For i = 0 To UBound(MyPics, 2) - 1
********For j = i + 1 To UBound(MyPics, 2)
************If MyPics(1, i) > MyPics(1, j) Then
****************Temp1 = MyPics(0, j)
****************Temp2 = MyPics(1, j)
****************MyPics(0, j) = MyPics(0, i)
****************MyPics(1, j) = MyPics(1, i)
****************MyPics(0, i) = Temp1
****************MyPics(1, i) = Temp2
************End If
********Next j
****Next i
****
****For i = 0 To 2
********ActiveSheet.Pictures(MyPics(0, i)).Copy
********Range(MergedAreas(i)).PasteSpecial
****Next i
****
****Range("A1").Select
****
****Application.ScreenUpdating = True
****
End Sub

Sub DeleteRandomPics()

****Dim Pic As Picture

****For Each Pic In ActiveSheet.Pictures
********If Union(Pic.TopLeftCell, Range("A173:O173")).Address = Range("A173:O173").Address Then
************Pic.Delete
********End If
****Next Pic
****
End Sub