[Solved] Excel VBA to build bingo cards with pictures instead of numbers

by


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

solved Excel VBA to build bingo cards with pictures instead of numbers