麻辣家族討論版版 - Powered by Discuz! Board

標題: vba 如何修改新增公式可以自動貼下一排 [打印本頁]

作者: Muffledsatyr 時間: 2021-4-12 09:53 標題: vba 如何修改新增公式可以自動貼下一排

想要貼滿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 時間: 2021-4-12 15:31

回復 1# Muffledsatyr

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

作者: Muffledsatyr 時間: 2021-4-14 10:04

回復 2# samwang

[attach]33204[/attach]

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

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

以上~請求大神幫忙!!

作者: samwang 時間: 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

作者: Muffledsatyr 時間: 2021-4-15 06:52

回復 4# samwang

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

作者: ML089 時間: 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

作者: ML089 時間: 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

作者: samwang 時間: 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

作者: Muffledsatyr 時間: 2021-4-16 10:46

回復 7# ML089

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

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

作者: Muffledsatyr 時間: 2021-4-16 10:47

回復 8# samwang

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

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

作者: Muffledsatyr 時間: 2021-4-16 11:16

回復 ML089

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

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

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

非常感謝~

作者: Muffledsatyr 時間: 2021-4-16 11:18

回復 samwang

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

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

非常感謝~

作者: samwang 時間: 2021-4-16 11:25

回復 12# Muffledsatyr

圖片高度5.79公分寬度7.72公分有辦法加入嗎?
Set sShape = ActiveSheet.Shapes.AddPicture(PicList(i), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
Rng.Width , Rng Height 可以直接改成你需要的數值如下，如果不改就是依照excel實際大小貼入
Set sShape = ActiveSheet.Shapes.AddPicture(PicList(i), msoFalse, msoCTrue, Rng.Left, Rng.Top, 7.72, 5.79)

作者: samwang 時間: 2021-4-16 11:43

回復 12# Muffledsatyr

請測試看看，不太了解是不是你要的結果，謝謝

Sub tt2()
Dim PicList, PicFormat$, Rng As Range, sShape As Shape, i&, X%, Y%
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
X = 1
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)
      Cells(X, Y).ColumnWidth = 42  '設定excel寬度
      Cells(X, Y).RowHeight = 170 '設定excel高度
      Set sShape = ActiveSheet.Shapes.AddPicture(PicList(i), msoFalse, msoCTrue, Rng.Left, Rng.Top, 7.72, 5.79)  '數字可設定照片寬高
Next
End If
End Sub

作者: Muffledsatyr 時間: 2021-4-17 10:20

回復 14# samwang

測試過後EXCEL欄寬有變，可使圖片沒有變...不過還是謝謝你 ^0^
[attach]33214[/attach]

作者: Muffledsatyr 時間: 2021-4-17 10:32

回復 15# Muffledsatyr

我有改數值!!感覺那個好像是單位的問題!!
例如公分和像素的問題導致圖片大小的差異....非常感謝!!!

作者: samwang 時間: 2021-4-17 11:04

回復 15# Muffledsatyr

請再測試看看，是不是您的需求，謝謝

圖片在Excel高度5.79公分寬度7.72公分
下列程式碼需修改數值如下, 未來可自行修改所需
高度: 5.79 / 0.0353 = 164
寬度: 7.72 / 0.0353 = 219

Set sShape = ActiveSheet.Shapes.AddPicture(PicList(i), msoFalse, msoCTrue, Rng.Left, Rng.Top, 219, 164) '數字可設定照片寬高

作者: Muffledsatyr 時間: 2021-4-19 09:31

回復 17# samwang

嗯嗯沒關係我依照你的公式修改了!!
真的方便很多，幾百張圖不需人工一一調整了!!非常感謝~

作者: Muffledsatyr 時間: 2021-7-14 19:38

回復 Muffledsatyr

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

Sub tt()
Dim PicList, PicFormat$, Rng A ...
samwang 發表於 2021-4-15 13:53

最近公司電腦為了節省經費更換成LIBRE，執行VBA時都無法執行!!
想請問有什麼方式能通用呢?謝謝....

作者: e86137 時間: 2021-7-16 06:16

回復 19# Muffledsatyr

LIBRE可以執行巨集嗎?
我公司也有買新電腦
裡面內建LIBRE結果原本寫好的巨集都不能用
只好自己灌Office 2007

作者: Muffledsatyr 時間: 2021-7-17 12:03

回復 Muffledsatyr

LIBRE可以執行巨集嗎?
我公司也有買新電腦
裡面內建LIBRE結果原本寫好的巨集都不 ...
e86137 發表於 2021-7-16 06:16

按熱鍵是有出現類似巨集的畫面，可是貼上後一樣無法使用才來跪求大神!!

Orz...

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)