|
本身的想法是批量新建工作簿,然后在遍历每个工作簿并插入图表,但是不会弄 。就试一下直接在新建工作簿的时候插入图片,然后找了这样一个插入的代码嵌套进去,然后运行就没反应了,也不报错什么,不知道该调哪里 ,请各位老师有时间帮忙改一下,万分感谢呀。
目录和模板都在这个路径下面 E:\工作\test\目录.xlsx E:\工作\test\模板.xlsx 图片目录是 E:\工作\test\图片\200151.png
Public Sub 生成并加图片()
'On Error Resume Next '// 发生错误,自动执行下一句,就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Application.EnableEvents = False '//禁止触发其他事件
Application.StatusBar = True '关闭系统状态条
Dim i As Integer
Windows("目录.xlsm").Activate
Sheets("sheet1").Activate
c = Application.CountA(Range("a1:a1000"))
For i = 2 To c
Windows("目录.xlsm").Activate
Cells(i, 1).Select
Selection.Copy
Workbooks.Open ("E:\工作\test\模板.xlsx")
Windows("模板.xlsx").Activate
Range("X2").Select
ActiveSheet.Paste
Set fso = CreateObject("Scripting.FileSystemObject")
Cells(6, 16).Select
Set Rng = Selection
str1 = ThisWorkbook.Path & "\图片\" & Cells(7, 14) & ".png"
If fso.FileExists(str1) Then
ActiveSheet.Pictures.Insert(str1).Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Left = Rng.Left + 1
.Top = Rng.Top + 1
.Width = Rng.Offset(0, 1).Left - Rng.Left - 2
w = Rng.Offset(1, 0).Top
y = Rng.Top
.Height = w - y - 2
End With
End If
Windows("模板.xlsx").Activate
ActiveWorkbook.SaveAs Filename:="工作\test\ 测试" & [x2] & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Next
i = i + 1 '循环
Application.StatusBar = False '恢复系统状态条
Application.EnableEvents = True '// '//恢复触发其他事件
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
End Sub
|
|