標題: [發問] 請問如何在excel裡面利用輸入圖名vba貼圖 [打印本頁]

---

作者: xlarge16803    時間: 2014-4-23 18:38     標題: 請問如何在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

---

作者: GBKEE    時間: 2014-4-24 05:25

本帖最後由 GBKEE 於 2014-4-24 05:26 編輯

回復 1# xlarge16803

1. Option Explicit
   
2. Sub 載入圖片()
   
3.     Dim MyRng As Range, XR As Range, uPath$, y&, xFile$
   
4.     Set MyRng = [A3]
   
5.     If [A3] = "" Then MsgBox "無圖檔名稱！": Exit Sub
   
6.     'ThisWorkbook.Path 傳回這活頁簿檔案存檔的路徑 如 ="C:\"
   
7.     uPath = ThisWorkbook.Path & "c:/my picture/" ' =>"C:\c:/my picture/" 這是錯誤的路徑?
   
8.     '是這樣吧!!
   
9.     uPath = ThisWorkbook.Path '->= "c:/my picture" 對嗎???
   
10.     If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到圖檔資料夾！": Exit Sub
    
11.     ActiveSheet.Pictures.Delete
    
12.     Application.ScreenUpdating = False
    
13.     For Each XR In Union([B3], [C3], [D3], [E3])
    
14.         y = y + 1
    
15.         xFile = uPath & "\" & MyRng & "-" & y & ".JPG"
    
16.         If Dir(xFile) <> "" Then
    
17.             With ActiveSheet.Pictures.Insert(xFile)
    
18.             .ShapeRange.LockAspectRatio = msoFalse
    
19.             .Width = XR.Width
    
20.             .Height = XR.Height
    
21.             .Left = XR.Left
    
22.             .Top = XR.Top
    
23.             End With
    
24.         End If
    
25.     Next
    
26. End Sub

複製代碼

---

作者: xlarge16803    時間: 2014-4-25 09:52

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

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

---

作者: GBKEE    時間: 2014-4-25 09:56

回復 3# xlarge16803
沒看檔案及程式碼,如何會知道你錯誤在哪裡.

---

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

---

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