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

Muffledsatyr

中學生 Rank: 2

帖子: 17
主題: 4
精華: 0
積分: 67
點名: 0
作業系統: Win7 & Win10
軟體版本: Office 2003 & Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2020-2-4
最後登錄: 2024-4-19

12^# 跳轉到 »

發表於 2021-4-16 11:18 | 只看該作者

回復 samwang

太棒了!!
固定A1我剛好也需要 XD!!真是挖到寶了!!非常感謝神人出手幫忙....
...
Muffledsatyr 發表於 2021-4-16 10:47

像這樣的條件...
EXCEL欄寬42 列高170
圖片高度5.79公分寬度7.72公分有辦法加入嗎?

非常感謝~

TOP

Muffledsatyr

中學生 Rank: 2

帖子: 17
主題: 4
精華: 0
積分: 67
點名: 0
作業系統: Win7 & Win10
軟體版本: Office 2003 & Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2020-2-4
最後登錄: 2024-4-19

11^#

發表於 2021-4-16 11:16 | 只看該作者

回復 ML089

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

另 ...
Muffledsatyr 發表於 2021-4-16 10:46

像這樣的條件...
EXCEL欄寬42 列高170
圖片高度5.79公分寬度7.72公分有辦法加入嗎?

非常感謝~

TOP

Muffledsatyr

中學生 Rank: 2

帖子: 17
主題: 4
精華: 0
積分: 67
點名: 0
作業系統: Win7 & Win10
軟體版本: Office 2003 & Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2020-2-4
最後登錄: 2024-4-19

10^#

發表於 2021-4-16 10:47 | 只看該作者

回復 8# samwang

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

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

TOP

Muffledsatyr

中學生 Rank: 2

帖子: 17
主題: 4
精華: 0
積分: 67
點名: 0
作業系統: Win7 & Win10
軟體版本: Office 2003 & Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2020-2-4
最後登錄: 2024-4-19

9^#

發表於 2021-4-16 10:46 | 只看該作者

回復 7# ML089

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

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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

8^#

發表於 2021-4-15 13:53 | 只看該作者

回復 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

TOP

ML089

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

7^#

發表於 2021-4-15 09:27 | 只看該作者

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

ML089

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

6^#

發表於 2021-4-15 09:16 | 只看該作者

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

Muffledsatyr

中學生 Rank: 2

帖子: 17
主題: 4
精華: 0
積分: 67
點名: 0
作業系統: Win7 & Win10
軟體版本: Office 2003 & Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2020-2-4
最後登錄: 2024-4-19

5^#

發表於 2021-4-15 06:52 | 只看該作者

回復 4# samwang

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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2026-5-26

4^#

發表於 2021-4-14 11:27 | 只看該作者

回復 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

TOP

Muffledsatyr

中學生 Rank: 2

帖子: 17
主題: 4
精華: 0
積分: 67
點名: 0
作業系統: Win7 & Win10
軟體版本: Office 2003 & Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2020-2-4
最後登錄: 2024-4-19

3^#

發表於 2021-4-14 10:04 | 只看該作者

回復 2# samwang

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

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

以上~請求大神幫忙!!

TOP

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]