Excel VBA构建宾果卡与图片，而不是数字 [英] Excel VBA to build bingo cards with pictures instead of numbers

问题描述

  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 
 
当bcontinue 
 sFilename = Worksheets（1）.Cells（i， 1）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
单元格（i，7）。选择
 ActiveSheet.Pictures。 Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 50 
 Selection.ShapeRange.Width = 50 
i = i + 1 
结束如果
 Wend 
 
关于错误简历Next 
 
 
 spath =位置
 
i = 2 
 
 bcontinue = True 
 
 bcontinue 
 sFilename = Worksheets（1）.Cells（i，2）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
单元格（i，8）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 50 
 Selection.ShapeRange.Width = 50 
i = i + 1 
结束如果
 
 
 Wend 
 
关于错误恢复下一个
 
 spath =位置
 
i = 2 
 
 bcontinue = True 
 
 bcontinue 
 sFilename = Worksheets（1）.Cells（i，3） .Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
 
单元格（i，9）。选择
 ActiveSheet。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 50 
 Selection.ShapeRange.Width = 50 
i = i + 1 
结束如果
 
 Wend 
 
关于错误简历Next 
 
 spath =location
 
i = 2 
 
 bcontinue = True 
 
 bcontinue 
 sFilename = Worksheets（1）.Cells（i，4）.Value 
如果sFilename =然后
 bcontinue = False 
 E lse 
 
 
单元格（i，10）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 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 
 
虽然bcontinue 
 sFilename = Worksheets（1）.Cells（i，5）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
单元格（i，11）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 50 
 Selection.ShapeRange.Width = 50 
i = i + 1 
结束如果
 
 Wend 
 End Sub 
  

我是一个100％的新手，所以我不知道如何让进程运行一次通过我想要的行和列，所以我只是有相同的代码重复5次创建5x5。目前，这项工作是为了创建5x5的图片，我正在开发一种随机数字的方法，以便我可以打印几张卡片并随机再次使用。

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

• 使图片适合单元格（或自动调整单元格


• 获取公式以跳过空格，以便一次可以多张卡片。


• 不知道如何把我想要的具体图片放入每张卡。我知道我可以如何做（我会的）像第一张卡，但我不知道如何使它重复地为每张卡做的。

任何帮助都不胜感激。谢谢。

解决方案

我保证，这绝对不是最好的或最快的方式来完成这项工作，我感到自豪的是，即使我找到了代码的一部分，并且必须将它们组合起来，我自己也可以自己构建。

使用下面的代码制作4张卡片的数字。

 子号（）
 Dim FillRange As Range，c作为范围
设置FillRange =范围（A1：A5）
对于每个c在FillRange 
 Do 
 c.Value = Int（（15  -  1 + 1）* Rnd + 1）
循环直到WorksheetFunction.CountIf（FillRange，c.Value） 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 End Sub 
 
 
 
 Sub number5（）
 Dim FillRange As Range，c As Range 
 Set FillRange =范围（A7：A11）
对于每个c在FillRange 
 Do 
 c.Value = Int（（15  -  1 + 1）* Rnd + 1）
循环直到WorksheetFunction.CountIf（FillRange，c.Value） 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 End Sub 
 
 
 
子编号10（）
 Dim FillRange As Range，c As Range 
 Set FillRange =范围（A13：A17）
对于每个c在FillRange 
 Do 
 c.Value = Int（（15  -  1 + 1）* Rnd + 1）
循环直到WorksheetFunction.CountIf（FillRange，c.Value） 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 End Sub 
 
 
 
 
 
子号码15（）
 Dim FillRange As Range，c作为范围
设置FillRange =范围（A19：A23）
对于每个c在FillRange 
 Do 
 c.Value = Int（（15  -  1 + 1）* Rnd + 1）
循环直到WorksheetFunction.CountIf（FillRange，c.Value） 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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）
循环直到WorksheetFunction.CountIf（FillRange，c.Value）< ; 2 
下一个
 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 
 
 bcontinue 
 sFilename = Worksheets（1）.Cells（i，1）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
'设置位置图A = 1 
 
单元格（i，11 ）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 83.25 
 Selection.ShapeRange.Width = 82 
i = i + 1 
结束如果
 Wend 
 
关于错误简历Next 
 
 
 spath =C：\Users\etc。 
 
i = 2 
 
 bcontinue = True 
 
虽然bcontinue 
 sFilename = Worksheets（1）.Cells（i，3）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
'设置位置图A = 1 
 
单元格（i，13 ）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 83.25 
 Selection.ShapeRange.Width = 82 
i = i + 1 
结束如果
 
 
 Wend 
 
关于错误简历Next 
 
 
 spath =C：\Users\etc。 
 
i = 2 
 
 bcontinue = True 
 
虽然bcontinue 
 sFilename = Worksheets（1）.Cells（i，5）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
'设置位置图A = 1 
 
单元格（i，15 ）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 83.25 
 Selection.ShapeRange.Width = 82 
i = i + 1 
结束如果
 
 
 Wend 
 
关于错误简历Next 
 
 
 spath =C：\Users\etc。 
 
i = 2 
 
 bcontinue = True 
 
 bcontinue 
 sFilename = Worksheets（1）.Cells（i，7）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
'设置位置图A = 1 
 
单元格（i，17 ）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 83.25 
 Selection.ShapeRange.Width = 82 
i = i + 1 
如果
 
 
 Wend 
错误简历Next 
 
 
 spath =C：\Users\etc。 
 
i = 2 
 
 bcontinue = True 
 
 bcontinue 
 sFilename = Worksheets（1）.Cells（i，9）.Value 
如果sFilename =然后
 bcontinue = False 
 Else 
 
'设置位置图A = 1 
 
单元格（i，19 ）。选择
 ActiveSheet.Pictures.Insert（spath + sFilename +.jpg）。选择
 Selection.ShapeRange.LockAspectRatio = msoFalse 
 Selection.ShapeRange.Height = 83.25 
 Selection.ShapeRange.Width = 82 
i = i + 1 
 End If 
 
 
 Wend 
 End Sub 
  

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.

解决方案

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

这篇关于Excel VBA构建宾果卡与图片，而不是数字的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！