VBA代码求助！！！

hranta

路过大侠请您伸出援手，求助修改下代码增加以下功能，不胜感激！

山菊花

供参考。

蓝桥玄霜

1. Sub FindFile()
   
2. Dim Arr, i&, pth$, ML, MT, MW, MH, shp, s$, fNm$, s1$
   
3. Application.ScreenUpdating = False
   
4. Myr = [d65536].End(xlUp).Row
   
5. Arr = Range("a3:g" & Myr)
   
6. pth = ThisWorkbook.Path & ""
   
7. Call FindFileName(pth)
   
8. k = d.keys
   
9. For Each shp In ActiveSheet.Shapes
   
10.     If shp.Type = msoAutoShape Then
    
11.         shp.Delete
    
12.     End If
    
13. Next
    
14. For i = 1 To UBound(Arr)
    
15.         s1 = Arr(i, 2) & Arr(i, 3) & Arr(i, 4)
    
16.         s = s1 & ".jpg"
    
17.         If s = ".jpg" Then GoTo 100
    
18.         If d.exists(s) Then
    
19.             fNm = d(s)
    
20.         Else
    
21.             GoTo 100
    
22.         End If
    
23.         With Cells(i + 2, 5)
    
24.             ML = .Left
    
25.             MT = .Top
    
26.             MW = .Width
    
27.             MH = .Height
    
28.             ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    
29.             Selection.ShapeRange.Fill.UserPicture fNm
    
30.         End With
    
31.         With Cells(i + 2, 6)
    
32.             ML = .Left
    
33.             MT = .Top
    
34.             MW = .Width
    
35.             MH = .Height
    
36.             ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    
37.             Selection.ShapeRange.Fill.UserPicture Split(fNm, ".")(0) & "2.jpg"
    
38.         End With
    
39. 100:
    
40. Next
    
41. Application.ScreenUpdating = True
    
42. End Sub

复制代码

hranta

山菊花 发表于 2020-2-25 19:35
供参考。

感激涕零