返回列表 上一主題 發帖

vba 如何修改新增公式 可以自動貼下一排

Sub InsertPictures_5()

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
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

'貼滿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
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

        靜思自在 : 【時間無法遮擋】怕時間消逝,花了許多心血,想盡各式方法要遮擋時間,結果是:浪費了更多時間,且一無所成!
返回列表 上一主題