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

rdimbleby82

New Member
Joined
Jul 1, 2010
Messages
6
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
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
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>
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,490
Messages
6,113,956
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top