[已解决]提取相同图片名称的图片.ra ...

水木

提取相同图片名称的图片.rar (590.54 KB, 下载次数: 12)

2015-9-7 22:02 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2015-9-7 23:22

……………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim fs, d, i&, j%, rng As Range
   
4. Set fs = CreateObject("scripting.FileSystemObject")
   
5. Set d = CreateObject("scripting.dictionary")
   
6. mypath = ThisWorkbook.Path & ""
   
7. Application.ScreenUpdating = False
   
8. Application.DisplayAlerts = False
   
9. For i = Sheets.Count To 1 Step -1
   
10.     If Sheets(i).Name <> "界面" Then Sheets(i).Delete
    
11. Next
    
12. For Each f In fs.GetFolder(mypath).SubFolders
    
13.     wj = Dir(f & "\*.*")
    
14.     Do While wj <> ""
    
15.         w = Split(wj, ".")(0)
    
16.         If Not d.Exists(w) Then
    
17.             d(w) = f & "" & wj
    
18.         Else
    
19.             d(w) = d(w) & " " & f & "" & wj
    
20.         End If
    
21.         wj = Dir
    
22.    Loop
    
23. Next
    
24. a = d.Keys: b = d.Items
    
25. For i = 0 To d.Count - 1
    
26.     x = Split(b(i))
    
27.     With Sheets.Add(after:=Sheets(Sheets.Count))
    
28.         .Name = a(i)
    
29.         For j = 0 To UBound(x)
    
30.             Set rng = .Cells(1, j * 4 + 1).Resize(10, 3)
    
31.             .Shapes.AddShape(msoShapeRectangle, rng.Left, rng.Top, rng.Width, rng.Height).Select
    
32.             Selection.ShapeRange.Fill.UserPicture x(j)
    
33.         Next
    
34.     End With
    
35. Next
    
36. Application.DisplayAlerts = True
    
37. Application.ScreenUpdating = True
    
38. End Sub

复制代码

dsmch

……………………