各位大神如何用VBA编写自动插入图片

tzzhonghang

就是在这表里选择用插入的图片，他会自动把图片的名字写入下面的单元格里，然后相应的图片自动插入上面的单元格里，并自动调整为1寸的，2寸的，按照单元格的上边和左边，图片自动对齐

约定的童话

附件模拟的没有图片啊

zhanghai0602

1. Sub crPicturs()
   
2.     If ActiveSheet.Name = "1寸" Then crJpg 6
   
3.     If ActiveSheet.Name = "2寸" Then crJpg 4
   
4. End Sub
   
5. Sub crJpg(SizeX%)
   
6.     Application.ScreenUpdating = False
   
7.     Dim MyFile$, PathX$
   
8.     Dim arr$(300)
   
9.     Dim I%, J%, K%, L%
   
10.     Dim Hx!, Wx!
    
11.     Dim Shp As Shape
    
12.     For Each Shp In ActiveSheet.Shapes
    
13.         Shp.Delete
    
14.     Next
    
15.     Cells.ClearContents
    
16.     PathX = ThisWorkbook.Path & ""
    
17.     MyFile = Dir(PathX & "*.jpg")
    
18.     J = 0
    
19.     Do While MyFile <> ""
    
20.         J = J + 1
    
21.         arr(J) = MyFile
    
22.         MyFile = Dir
    
23.     Loop
    
24.     For I = 1 To J
    
25.         K = (I \ SizeX) * 2
    
26.         L = I Mod SizeX
    
27.         If L = 0 Then
    
28.             L = SizeX
    
29.             K = K - 2
    
30.         End If
    
31.         With Cells(K + 1, L)
    
32.             .Select
    
33.             Hx = .RowHeight
    
34.             Wx = .Width
    
35.         End With
    
36.         ActiveSheet.Pictures.Insert(PathX & arr(I)).Select
    
37.         Selection.Placement = xlFreeFloating
    
38.         With Selection.ShapeRange
    
39.             .LockAspectRatio = msoFalse
    
40.             .Height = Hx
    
41.             .Width = Wx
    
42.         End With
    
43.         Cells(K + 2, L) = arr(I)
    
44.     Next
    
45.     Application.ScreenUpdating = True
    
46.     Cells(1, 1).Select
    
47. End Sub

复制代码

代码已测试无误,你试下

tzzhonghang

zhanghai0602 发表于 2019-8-20 19:04
代码已测试无误,你试下

运行时显示当前范围内的声明重复 SizeX%

tzzhonghang

约定的童话 发表于 2019-8-20 18:00
附件模拟的没有图片啊

就是平常工人的一些电子照片

zhanghai0602

tzzhonghang 发表于 2019-8-21 08:36
运行时显示当前范围内的声明重复 SizeX%

Dim I%, J%, K%, L%, SizeX%
以上声明改为以下
Dim I%, J%, K%, L%

tzzhonghang

zhanghai0602 发表于 2019-8-21 08:39
Dim I%, J%, K%, L%, SizeX%
以上声明改为以下
Dim I%, J%, K%, L%

显示溢出堆栈空间  crJpg6

zhanghai0602

tzzhonghang 发表于 2019-8-21 08:42
显示溢出堆栈空间  crJpg6

    PathX = ThisWorkbook.Path & "\"
这一句

tzzhonghang

zhanghai0602 发表于 2019-8-21 08:45
PathX = ThisWorkbook.Path & "\"
这一句

还是一样的

tzzhonghang

约定的童话 发表于 2019-8-20 18:00
附件模拟的没有图片啊

已重新上存附件