Excel VBA用图片而不是数字来构建宾果卡

时间：2014-11-06 21:27:12

标签： excel image vba excel-vba random

编辑 - 我正在使用的当前代码如下：

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

我是100％的新手，所以我不确定如何通过我想要的行和列运行一次，所以我只需要重复5次相同的代码来创建5x5。目前这可以创建5x5的图片，我正在设计一个随机数字的方式，这样我就可以打印几张卡片并再次随机化并拉入新照片。

以下是我可以使用的一些指导：

  • 使用当前设置的尺寸使图片适合单元格（或自动将单元调整为此大小）。
  • 让公式跳过一个空格，这样我就可以一次做多张卡片。
  • 不确定如何将我想要的特定图片放入每张卡片中。我知道我怎么能这样做（而且我会）像第一张卡一样，但我不知道如何重复为每张卡制作它。

感谢任何帮助。谢谢。

2 个答案:

答案 0 :(得分：1)

我保证这绝不是最好或最快的方法来完成这项任务但是它有效并且我为自己能够自己构建它而感到自豪，即使我找到了部分代码并且必须结合它们。

以下代码用于制作4张卡片。 

    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
  

我确实制作了另一个子组件来同时运行所有这些。

     

**这里的代码是从另一页上的生成器引用的数字来从我的文件夹中提取图像   改名为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

答案 1 :(得分：0)

这将帮助您入门

我在excel表上放了52张图片，我将G5：K9的大小调整为与图像大小相同

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
相关问题
最新问题