怎么用VB实现批量导入相片及复制工作表

ZOL单子

怎么用VB实现批量导入相片及复制工作表？

各位好，我现在有个需求，一个excel中，根据清单，赋值给模板表并复制一份，然后根据编号来自动命名新工作表，这一部分的代码已经实现，但我这个模板表中还要插入4张图片，如何批量来实现呢 ？

要求：
1、复制出来的工作表，每个表的四张图片不一样，用点位编号命名的文件夹装着，如DP-001\1、DP-001\2……
2、插入的图片长宽要求一致，如果是横着的相片，要求宽度一致，不然排版会变化


感谢大神，希望给于帮助，文件请查看附件，谢谢各位！

蓝桥玄霜

http://club.excelhome.net/thread-1191893-1-1.html

ione_fox

1. Sub 新建隐蔽工程工作表()
   
2. Dim i%, r%, y%
   
3. Application.DisplayAlerts = False
   
4. Dim sh As Worksheet
   
5. For Each sh In Worksheets
   
6. If sh.Name <> "数据表" And sh.Name <> "sheet1" Then sh.Delete
   
7. Next sh
   
8. Application.DisplayAlerts = True
   
9. For i = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
   
10.    Sheets(2).Cells(4, 3) = Sheets(1).Cells(i, 1) '点位编号
    
11.    Sheets(2).Cells(4, 8) = Sheets(1).Cells(i, 2) '点位位置
    
12.    Sheets(2).Cells(5, 3) = Sheets(1).Cells(i, 3)  '区域
    
13.    Sheets(2).Cells(5, 8) = Sheets(1).Cells(i, 4)  '施工日期
    
14.    Sheets(2).Cells(2, 10) = Sheets(1).Cells(i, 5)  '文档编号
    
15.     Sheets(2).Copy After:=Sheets(Sheets.Count)
    
16.    ActiveSheet.Name = Sheets(1).Cells(i, 1) '用点位编号来命名工作表
    
17. '========================================================================
    
18. Dim Name$, Path, RG
    
19. For Each RG In Union(Range("a18"), Range("g18"), Range("a22"), Range("g22"))
    
20.     Name = ActiveSheet.Name & "" & Right(RG, 1) & ".jpg"
    
21.     Path = ThisWorkbook.Path & "" & Name
    
22.     If Dir(Path) <> "" Then
    
23.         With RG.MergeArea
    
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 Path
    
30.         End With
    
31.     End If
    
32. Next
    
33. Next
    
34. End Sub

复制代码

ione_fox

附件请测试，好用请给予好评 给个花

ZOL单子

ione_fox 发表于 2018-8-31 15:26
附件请测试，好用请给予好评 给个花

感谢，感谢，万分感谢，我先用一下看看。