Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape, n
On Error Resume Next
'ActiveSheet.Pictures.Delete '刪除全部圖片
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
Set Rng = Application.ActiveCell
If IsArray(PicList) Then
For lLoop = LBound(PicList) To UBound(PicList)
Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
n = n + 1
If n = 5 Then
n = 0
Set Rng = Rng.Offset(1, -4)
Else
Set Rng = Rng.Offset(0, 1)
End If
Next
End If
End Sub
'貼滿5個後,換下一排在貼5個....以此類推
'注意! 執行程式前先選定貼圖執行位置
Sub InsertPictures_5()
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape, n, Pages
On Error Resume Next
'ActiveSheet.Pictures.Delete '刪除全部圖片
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
Set Rng = Application.ActiveCell
Pages = 5 '控制變數:貼滿5個後,換下一排在貼5個
If IsArray(PicList) Then
For lLoop = LBound(PicList) To UBound(PicList)
Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
n = n + 1
If n = Pages Then '滿5格後
n = 0
Set Rng = Rng.Offset(1, 1 - Pages) '跳下一列,退回原起點
Else
Set Rng = Rng.Offset(0, 1)
End If
Next
End If
End Sub