[發問] 請問如何在excel裡面利用輸入圖名vba貼圖

由於資料數量有一千多筆所以想起應該可以用巨集方式執行，
利用前面輸入的編號寫一個巨集去開啟c:/my picture/001，並貼上這個圖檔
但是我對巨集還停在錄製階段所以不知道該怎麼做，請高手幫忙嚕。感激不盡

　１．A３輸入圖名 (例如輸入1-15 就出現編號1-15的圖)，
依序在(B3．C3．D3．E3．B4．C4．D4．E4.....B6．C6．D6)以此類推貼入圖檔，
　　　檔名為(1.jpg．2.jpg．3.jpg.．4.jpg......15.jpg)
　２．圖片自動調整與儲存格相同大小。
　
Sub 載入圖片()
　Dim MyRng As Range, xR As Range, uPath$, y&, xFile$
　Set MyRng = [A3]
　If [A3] = "" Then MsgBox "無圖檔名稱！": Exit Sub
　uPath = ThisWorkbook.Path & "c:/my picture/"
　If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到圖檔資料夾！": Exit Sub
　ActiveSheet.Pictures.Delete
　Application.ScreenUpdating = False
　For Each xR In Union([B3], [C3], [D3], [E3])
　　　y = y + 1
　　　xFile = uPath & "\" & MyRng & "-" & y & ".JPG"
　　　If Dir(xFile) = "" Then GoTo 101
　　　With ActiveSheet
　　　　　.Pictures.Insert (xFile)
　　　With .Shapes(.Shapes.Count)
　　　　　.LockAspectRatio = msoFalse
　　　　　.Width = xR.Width
　　　　　.Height = xR.Height
　　　　　.Left = xR.Left
　　　　　.Top = xR.Top
　　　End With
　　　End With
　101: Next
　End Sub

樓主熱帖

xlarge16803

小學生 Rank: 1

帖子: 7
主題: 4
精華: 0
積分: 15
點名: 0
作業系統: WIN10
軟體版本: Office2003
閱讀權限: 10
性別: 女
來自: 台灣
註冊時間: 2014-4-23
最後登錄: 2017-5-14

2^#

發表於 2014-4-25 09:52 | 顯示全部帖子

感謝大大解答
不意思再請教一下
改成sheet1 A３輸入圖名 (例如輸入1-15 就出現編號1-15的圖) 按貼圖巨集鈕
貼在sheet2 依序在(B3．C3．D3．E3．B4．C4．D4．E4.....B6．C6．D6)以此類推貼入圖檔

改之後一動也不動要這麼改...

TOP

xlarge16803

小學生 Rank: 1

帖子: 7
主題: 4
精華: 0
積分: 15
點名: 0
作業系統: WIN10
軟體版本: Office2003
閱讀權限: 10
性別: 女
來自: 台灣
註冊時間: 2014-4-23
最後登錄: 2017-5-14

3^#

發表於 2014-4-25 11:04 | 顯示全部帖子

抱歉!!
附上程式碼..
我想在公司用這個程式路徑圖是\\178.153.85\fast\品質管理G\ 是否也可以抓圖
非常感謝大大解答
Sheets("Sheet1").Select
Sub 載入圖片()
Dim MyRng As Range, XR As Range, uPath$, y&, xFile$
Set MyRng = [A3]
If [A3] = "" Then MsgBox "無圖檔名稱！": Exit Sub
'ThisWorkbook.Path 傳回這活頁簿檔案存檔的路徑如 ="C:\"
uPath = ThisWorkbook.Path & "c:/my picture/" ' =>"C:\c:/my picture/" 這是錯誤的路徑?
'是這樣吧!!
uPath = ThisWorkbook.Path '->= "c:/my picture" 對嗎???
If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到圖檔資料夾！": Exit Sub
ActiveSheet.P2ctures.Delete
Sheets("Sheet1").Select
Application.ScreenUpdating = False
For Each XR In Union([B3], [C3], [D3], [E3])
      y = y + 1
      xFile = uPath & "\" & MyRng & "-" & y & ".JPG"
      If Dir(xFile) <> "" Then
         With ActiveSheet.Pictures.Insert(xFile)
         .ShapeRange.LockAspectRatio = msoFalse
         .Width = XR.Width
         .Height = XR.Height
         .Left = XR.Left
         .Top = XR.Top
         End With
      End If
Next
End Sub

TOP