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

Muffledsatyr

想要貼滿5個後，換下一排在貼5個....以此類推
請幫幫我!!


公式如下:
Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xColIndex = xColIndex + 1
    Next
End If
End Sub

samwang

回復 1# Muffledsatyr


後學怕誤會意思，請問可以上傳範例嗎? 這樣比較容易了解，感謝。

Muffledsatyr

回復 2# samwang


   

下載 (184.19 KB)

2021-4-14 10:01

這是我期望中的圖!!
用VBA貼完模組後，在手動修改的!!


希望能5個一排後，直接跳下一排
並且能全部都調整圖片大小!!
貼5個調整大小是因為剛好EXCEL展開後的圖，差不多5個方便查看!!

以上~請求大神幫忙!!

samwang

回復 3# Muffledsatyr

請測試看看，謝謝
另外，有點不解就是你不是原來就有寫程式了嗎?


Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
     xRowIndex = Application.ActiveCell.Row
     For lLoop = LBound(PicList) To UBound(PicList)
        If xColIndex > 5 Then xRowIndex = xRowIndex + 1: xColIndex = 1
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xColIndex = xColIndex + 1
     Next
End If
End Sub

Muffledsatyr

回復 4# samwang


    原本就有寫沒錯!!不過寫的人離職了，而我部會這個太複雜了QQ

ML089

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

ML089

'貼滿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

samwang

回復 5# Muffledsatyr

固定從A1 開始排列，請試看看，謝謝

Sub tt()
Dim PicList, PicFormat$, Rng As Range, sShape As Shape, i&, X%, Y%
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
X = 1 '從A1開始
If IsArray(PicList) Then
    For i = 1 To UBound(PicList)
        Y = Y + 1
        If Y > 5 Then X = X + 1: Y = 1   '5張-->換下一列
        Set Rng = Cells(X, Y)  '貼上照片的位置
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(i), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
    Next
End If
End Sub

Muffledsatyr

回復 7# ML089


太棒了!!有各位神人真的幫我很大的忙!!有上百張~上千圖片要貼呢!!
真的非常感謝~

另外想請問如果想加入固定長寬或比例該加在公式哪邊?

Muffledsatyr

回復 8# samwang


   

太棒了!!
固定A1我剛好也需要 XD!!真是挖到寶了!!非常感謝神人出手幫忙....

另外想請問如果想加入固定長寬或比例該加在公式哪邊?