Excel VBA to build bingo cards with pictures inste

Question

Edit - The current code I am working with is below:

Dim i As Integer
Dim sFilename As String
Dim bcontinue As Boolean
Dim spath As String

Sub Attempt1()
On Error Resume Next


spath = "location"

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 1).Value
If sFilename = "" Then
bcontinue = False
Else

Cells(i, 7).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 50
Selection.ShapeRange.Width = 50
i = i + 1
End If
Wend

On Error Resume Next


spath = "location"

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 2).Value
If sFilename = "" Then
bcontinue = False
Else

Cells(i, 8).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 50
Selection.ShapeRange.Width = 50
i = i + 1
End If


Wend

On Error Resume Next

spath = "location"

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 3).Value
If sFilename = "" Then
bcontinue = False
Else


Cells(i, 9).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 50
Selection.ShapeRange.Width = 50
i = i + 1
End If

Wend

On Error Resume Next

spath = "location"

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 4).Value
If sFilename = "" Then
bcontinue = False
Else


Cells(i, 10).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 50
Selection.ShapeRange.Width = 50
i = i + 1
End If

Wend
On Error Resume Next

spath = "location"

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 5).Value
If sFilename = "" Then
bcontinue = False
Else

Cells(i, 11).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 50
Selection.ShapeRange.Width = 50
i = i + 1
End If

Wend
End Sub

I'm a 100% newbie so I'm not sure how to get the process to run once through the rows and columns I want so I just have the same code repeating 5 times to create the 5x5. Currently this works to create the 5x5 of pictures and I'm working on a way to have randomized numbers so that I can print a few cards and randomize it again and pull new photos in.

Below is what I could use some guidance on:

• Make the pictures fit into the cell (or automatically adjust the cells to this size) with the size currently set.
• Get the formula to skip over a blank space so I can do multiple cards at a time.
• Not sure how to put the specific picture I want into each card. I know how I could do it (and I will) for like the first card but I'm not sure how to make it repetitively do it for each card made.

Any help is appreciated. Thank you.

Answer 1

I promise this is in no way the best or fastest way to get this done but it works and I'm proud of the fact I was able to build it myself even if I did find parts of the code and had to combine them.

The code below is used to make 4 cards worth of numbers.

    Sub number()
Dim FillRange As Range, c As Range
Set FillRange = Range("A1:A5")
For Each c In FillRange
Do
c.Value = Int((15 - 1 + 1) * Rnd + 1)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number1()
Dim FillRange As Range, c As Range
Set FillRange = Range("b1:b5")
For Each c In FillRange
Do
c.Value = Int((30 - 16 + 1) * Rnd + 16)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number2()
Dim FillRange As Range, c As Range
Set FillRange = Range("c1:c5")
For Each c In FillRange
Do
c.Value = Int((45 - 31 + 1) * Rnd + 31)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number3()
Dim FillRange As Range, c As Range
Set FillRange = Range("d1:d5")
For Each c In FillRange
Do
c.Value = Int((60 - 45 + 1) * Rnd + 45)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number4()
Dim FillRange As Range, c As Range
Set FillRange = Range("e1:e5")
For Each c In FillRange
Do
c.Value = Int((75 - 61 + 1) * Rnd + 61)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub



Sub number5()
Dim FillRange As Range, c As Range
Set FillRange = Range("A7:A11")
For Each c In FillRange
Do
c.Value = Int((15 - 1 + 1) * Rnd + 1)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number6()
Dim FillRange As Range, c As Range
Set FillRange = Range("b7:b11")
For Each c In FillRange
Do
c.Value = Int((30 - 16 + 1) * Rnd + 16)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number7()
Dim FillRange As Range, c As Range
Set FillRange = Range("c7:c11")
For Each c In FillRange
Do
c.Value = Int((45 - 31 + 1) * Rnd + 31)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number8()
Dim FillRange As Range, c As Range
Set FillRange = Range("d7:d11")
For Each c In FillRange
Do
c.Value = Int((60 - 45 + 1) * Rnd + 45)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number9()
Dim FillRange As Range, c As Range
Set FillRange = Range("e7:e11")
For Each c In FillRange
Do
c.Value = Int((75 - 61 + 1) * Rnd + 61)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub



Sub number10()
Dim FillRange As Range, c As Range
Set FillRange = Range("A13:A17")
For Each c In FillRange
Do
c.Value = Int((15 - 1 + 1) * Rnd + 1)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number11()
Dim FillRange As Range, c As Range
Set FillRange = Range("b13:b17")
For Each c In FillRange
Do
c.Value = Int((30 - 16 + 1) * Rnd + 16)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number12()
Dim FillRange As Range, c As Range
Set FillRange = Range("c13:c17")
For Each c In FillRange
Do
c.Value = Int((45 - 31 + 1) * Rnd + 31)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number13()
Dim FillRange As Range, c As Range
Set FillRange = Range("d13:d17")
For Each c In FillRange
Do
c.Value = Int((60 - 45 + 1) * Rnd + 45)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number14()
Dim FillRange As Range, c As Range
Set FillRange = Range("e13:e17")
For Each c In FillRange
Do
c.Value = Int((75 - 61 + 1) * Rnd + 61)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub





Sub number15()
Dim FillRange As Range, c As Range
Set FillRange = Range("A19:A23")
For Each c In FillRange
Do
c.Value = Int((15 - 1 + 1) * Rnd + 1)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number16()
Dim FillRange As Range, c As Range
Set FillRange = Range("b19:b23")
For Each c In FillRange
Do
c.Value = Int((30 - 16 + 1) * Rnd + 16)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number17()
Dim FillRange As Range, c As Range
Set FillRange = Range("c19:c23")
For Each c In FillRange
Do
c.Value = Int((45 - 31 + 1) * Rnd + 31)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number18()
Dim FillRange As Range, c As Range
Set FillRange = Range("d19:d23")
For Each c In FillRange
Do
c.Value = Int((60 - 45 + 1) * Rnd + 45)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Sub number19()
Dim FillRange As Range, c As Range
Set FillRange = Range("e19:e23")
For Each c In FillRange
Do
c.Value = Int((75 - 61 + 1) * Rnd + 61)
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub

I did make another sub to run all of those at once.

**The code below here is what takes the numbers that are referenced from the generator on another page to pull the images from my folder which were renamed 1-75. **

Dim i As Integer
Dim sFilename As String
Dim bcontinue As Boolean
Dim spath As String

Sub Attempt1()
On Error Resume Next


spath = "C:\Users\etc."

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 1).Value
If sFilename = "" Then
bcontinue = False
Else

'Set Position Pic A = 1

Cells(i, 11).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 83.25
Selection.ShapeRange.Width = 82
i = i + 1
End If
Wend

On Error Resume Next


spath = "C:\Users\etc."

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 3).Value
If sFilename = "" Then
bcontinue = False
Else

'Set Position Pic A = 1

Cells(i, 13).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 83.25
Selection.ShapeRange.Width = 82
i = i + 1
End If


Wend

On Error Resume Next


spath = "C:\Users\etc."

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 5).Value
If sFilename = "" Then
bcontinue = False
Else

'Set Position Pic A = 1

Cells(i, 15).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 83.25
Selection.ShapeRange.Width = 82
i = i + 1
End If


Wend

On Error Resume Next


spath = "C:\Users\etc."

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 7).Value
If sFilename = "" Then
bcontinue = False
Else

'Set Position Pic A = 1

Cells(i, 17).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 83.25
Selection.ShapeRange.Width = 82
i = i + 1
End If


Wend
On Error Resume Next


spath = "C:\Users\etc."

i = 2

bcontinue = True

While bcontinue
sFilename = Worksheets(1).Cells(i, 9).Value
If sFilename = "" Then
bcontinue = False
Else

'Set Position Pic A = 1

Cells(i, 19).Select
ActiveSheet.Pictures.Insert(spath + sFilename + ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 83.25
Selection.ShapeRange.Width = 82
i = i + 1
End If


Wend
End Sub

Answer 2

This will get you started

I put 52 images on an excel sheet and I resized G5:K9 to be the same size as the images

Public Sub MakeBingoCard()

    Dim rCell As Range
    Dim shp As Shape

    ClearBingoCard

    'Put a random picture in each cell G5:K9 except the middle one
    For Each rCell In Sheet1.Range("G5").Resize(5, 5).Cells
        If rCell.Address <> "$I$7" Then
            'keep trying til you get an unused picture
            Do
                Set shp = Sheet1.Shapes("Picture " & Int(Rnd() * (52 - 1) + 1))
            Loop Until shp.Top > 1000

            'move the picture to the cell
            shp.Top = rCell.Top
            shp.Left = rCell.Left
        End If
    Next rCell

End Sub

Public Sub ClearBingoCard()

    Dim i As Long
    Dim shp As Shape

    'move all the pictures way below the card area
    For i = 1 To 52
        Set shp = Sheet1.Shapes("Picture " & i)
        If shp.Top < 1000 Then
            shp.Top = shp.Top + 1000
        End If
    Next i

End Sub