Hsieh

回復 1# jackyliu

圖片命名規則不是很懂，先試試這樣看怎樣不同

1. Sub Ex()
   
2. Dim A As Range, C As Range
   
3. ar = Array("C", "F", "T")
   
4. ay = Array(8, 9, 10)
   
5. ak = Array("", 0, 1, 2, 3)
   
6. fd = "C:\TEST\" '圖片目錄
   
7. With Sheet1
   
8. .Pictures.Delete
   
9. For Each C In .Range(.[C3], .[C65536].End(xlUp))
   
10. r = C.Row
    
11.     For i = 0 To 2
    
12.        For j = 0 To 3
    
13.        mystr = IIf(ak(j) = "", "", "-" & ak(j))
    
14.        fs = C & "-" & ar(i) & mystr & ".jpg"
    
15.        If Dir(fd & fs) <> "" Then
    
16.           Set A = .Cells(r, IIf(j = 0, ay(i), 10 + j))
    
17.           With .Pictures.Insert(fd & fs)
    
18.             .Top = A.Top: .Left = A.Left: .Height = A.Height: .Width = A.Width
    
19.           End With
    
20.        End If
    
21.        Next
    
22.     Next
    
23. Next
    
24. End With
    
25. End Sub

複製代碼

Hsieh

52-T-1要在編號52的哪一欄?
53.jpg 要在編號53的哪一欄?

Hsieh

回復 5# jackyliu


    H2、I2的C、F並沒有在圖片檔名的編號規則內嗎?
不然為何53.jpg  會在H欄位?
請在各儲存格位置填入圖片檔名，以釐清命名規則與表格位置的關係

Hsieh

回復 7# jackyliu

1. Sub Ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. fd = ThisWorkbook.Path & "\" '圖檔目錄
   
4. fs = Dir(fd & "*.jpg")
   
5. Do Until fs = ""
   
6. If InStr(fs, "-") = 0 Then '只有數值
   
7.    d(fs) = "H" & Val(fs) + 2 '因為在第列所以加2
   
8.    ElseIf Len(fs) - Len(Replace(fs, "-", "")) = 1 Then '只有1個分隔符號
   
9.    '第2碼為C就是I欄，否則就在J欄
   
10.      If Split(fs, "-")(1) = "C" Then d(fs) = "I" & Val(fs) + 2 Else d(fs) = "J" & Val(fs) + 2
    
11.    Else
    
12.    '第3碼是1就在K欄，2就在L欄，其餘在M欄
    
13.    k = IIf(Split(fs, "-")(2) = 1, "K", IIf(Split(fs, "-")(2) = 2, "L", "M"))
    
14.    d(fs) = k & Val(fs) + 2
    
15. End If
    
16. fs = Dir
    
17. Loop
    
18. With Sheet1
    
19. .Pictures.Delete '清除所有圖片
    
20. Application.ScreenUpdating = False
    
21. For Each ky In d.keys
    
22.    Set A = .Range(d(ky)) '圖片插入的位置
    
23.       With .Pictures.Insert(fd & ky) '插入圖檔
    
24.          .Top = A.Top
    
25.          .Left = A.Left
    
26.          .Height = A.Height
    
27.          .Width = A.Width
    
28.        End With
    
29. Next
    
30. End With
    
31. Application.ScreenUpdating = True
    
32. End Sub

複製代碼

Hsieh

回復 9# jackyliu
設定成儲存格大小

Hsieh

回復 12# jackyliu
If InStr(fs, "-") = 0 Then '只有數值
用INSTR函數測試看看圖片檔名是否有"-"號，因為只有數值時才沒有"-"號

d(fs) = "H" & Val(fs) + 2 '因為在第列所以加2
字典物件是用來儲存檔名對應的位址， Val(fs)會得到NO值，而NO的1是從第3列開始，所以列位要加2


至於你要增加欄位的問題，又回到之前的重點:檔名跟儲存欄位的對應規則
要自己清楚對應規則，然後在判斷式中一條件來寫入字典物件

Hsieh

回復 14# jackyliu

1. Sub Ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. fd = ThisWorkbook.Path & "\" '圖檔目錄
   
4. fs = Dir(fd & "*.jpg")
   
5. Do Until fs = ""
   
6. If InStr(fs, "-") = 0 Then '只有數值
   
7.    d(fs) = "H" & Val(fs) + 2 '因為在第列所以加2
   
8.    ElseIf Len(fs) - Len(Replace(fs, "-", "")) = 1 Then '只有1個分隔符號
   
9.    '第2碼為C就是I欄，否則就在J欄
   
10.      If Split(fs, "-")(1) = "C" Then d(fs) = "I" & Val(fs) + 2 Else d(fs) = "J" & Val(fs) + 2
    
11.    Else
    
12.    '第3碼是1就在K欄，2就在L欄，其餘在M欄
    
13.    ar = Split(fs, "-")
    
14.    p = IIf(ar(1) = "C", Asc("K"), Asc("L")) '第2碼是C就傳回"K"的字元碼，第2碼是T就傳回"L"的字元碼給變數p
    
15.    k = Chr(Val(ar(2)) + p) '字串變數k的值是第3碼+p對應到的字串(就是欄位)
    
16.    d(fs) = k & Val(fs) + 2
    
17. End If
    
18. fs = Dir
    
19. Loop
    
20. With Sheets("Sheet1")
    
21. .Pictures.Delete '清除所有圖片
    
22. Application.ScreenUpdating = False
    
23. For Each ky In d.keys
    
24.    Set A = .Range(d(ky)) '圖片插入的位置
    
25.       With .Pictures.Insert(fd & ky) '插入圖檔
    
26.          .ShapeRange.LockAspectRatio = msoFalse '解除長寬比例
    
27.          .Top = A.Top
    
28.          .Left = A.Left
    
29.          .Height = A.Height
    
30.          .Width = A.Width
    
31.        End With
    
32. Next
    
33. End With
    
34. Application.ScreenUpdating = True
    
35. End Sub

複製代碼

Hsieh

回復 16# jackyliu

1. Sub Ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. fd = ThisWorkbook.Path & "\" '圖檔目錄
   
4. fs = Dir(fd & "*.jpg")
   
5. Do Until fs = ""
   
6. If InStr(fs, "-") = 0 Then '只有數值
   
7.    d(fs) = "H" & Val(fs) + 2 '因為在第列所以加2
   
8.    ElseIf Len(fs) - Len(Replace(fs, "-", "")) = 1 Then '只有1個分隔符號
   
9.    '第2碼為C就是I欄，否則就在J欄
   
10.    V = Split(fs, "-")(1)
    
11.      If Split(fs, "-")(1) Like "C*" Then d(fs) = "I" & Val(fs) + 2 Else d(fs) = "J" & Val(fs) + 2
    
12.    Else
    
13.    '第3碼是1就在K欄，2就在L欄，其餘在M欄
    
14.    ar = Split(fs, "-")
    
15.    p = IIf(ar(1) = "C", Asc("K"), Asc("L")) '第2碼是C就傳回"K"的字元碼，第2碼是T就傳回"L"的字元碼給變數p
    
16.    k = Chr(Val(ar(2)) * 2 + p) '字串變數k的值是第3碼+p對應到的字串(就是欄位)
    
17.    d(fs) = k & Val(fs) + 2
    
18. End If
    
19. fs = Dir
    
20. Loop
    
21. With Sheets("Sheet1")
    
22. .Pictures.Delete '清除所有圖片
    
23. Application.ScreenUpdating = False
    
24. For Each ky In d.keys
    
25.    Set A = .Range(d(ky)) '圖片插入的位置
    
26.       With .Pictures.Insert(fd & ky) '插入圖檔
    
27.          .ShapeRange.LockAspectRatio = msoFalse '解除長寬比例
    
28.          .Top = A.Top
    
29.          .Left = A.Left
    
30.          .Height = A.Height
    
31.          .Width = A.Width
    
32.        End With
    
33. Next
    
34. End With
    
35. Application.ScreenUpdating = True
    
36. End Sub

複製代碼

Hsieh

用OPEN事件程序驅動即可開啟檔案就載入圖片
Sub Ex()
改成Sub auto_open()
把所有程式碼放在一般模組


檔案名稱只要是根據你的描述條件命名應該就沒錯

Hsieh

回復 20# jackyliu

手動刪除程式碼另存新檔就好啦
要自動另存時刪除程式碼，可利用BEFORE_SAVE事件完成(如附件)
insert_pictures.rar (1.74 MB)

下載次數: 28

2011-2-23 08:23