excel vba 批量复制图片报错“方法'copy'作用于对象'shape'时失败”

skylake

现在产生了一个新的疑惑，为什么用sleep的方式延时就无效呢？

cgzn

skylake 发表于 2020-11-27 13:20
现在产生了一个新的疑惑，为什么用sleep的方式延时就无效呢？

sleep延时不处理其他工作
doevent 不妨碍处理工作

mhps159357

skylake 发表于 2020-11-27 09:53
测试成功了，报错的原因还真是运行太快的原因，我在copy前面添加了延时，就能顺利运行下去了感谢@cgzn的提 ...

你修改了代码还是错误的啊，运行到11就报错了，你图片名称都跟表格名称不匹配，毫无疑问肯定出错，不要纠结这个问题了！错了就错了

skylake

mhps159357 发表于 2020-11-27 20:03
你修改了代码还是错误的啊，运行到11就报错了，你图片名称都跟表格名称不匹配，毫无疑问肯定出错，不要纠 ...

图片我已经全部重命名了，已经没问题了，不过我重复测试了几次，确实发现有点时候能成功，有点时候会报错，如果在每次.copy和.paste都加入一个缓冲的话，我测试是100%成功(重新上传了附件)，不够这样代码就有点冗余了，还是需要大神给指点一下迷津啊。

简七

Sub test()

Application.ScreenUpdating = False '关闭屏幕刷新
Dim shp As shape, sh As Worksheet, i As Integer, j As Integer, rng As Range
On Error Resume Next
For i = 2 To Sheets(1).[a1].End(xlDown).Row
    Set rng = Sheets(1).Cells(i, 1) '对应单元格值
    Set sh = ThisWorkbook.Sheets("图片" & rng.Value) '对应图片工作表
If sh Is Nothing Then Set sh = Sheets.Add(after:=Sheets(Sheets.Count)): sh.Name = "图片" & rng.Value Else sh.Activate: sh.Shapes.SelectAll: Selection.Delete '检查工作表是否为空,为空则新建工作表,否则激活工作表并删除表内shape对象
    sh.[a1] = rng.Value
    For j = 2 To 3 '复制图片
        Sheets(1).Shapes("图片" & rng.Value & j).Copy
        sh.Cells(1, j).Select
        sh.Paste
        sh.Cells(1, j).RowHeight = Sheets(1).Cells(i, j).RowHeight '单元格高度赋值为原高度
        sh.Cells(1, j).ColumnWidth = Sheets(1).Cells(i, j).ColumnWidth '单元格宽度赋值为原宽度
    Next
Set sh = Nothing '清空sh引用对象
Next
Sheets(1).Activate '激活工作表1
Application.ScreenUpdating = True '开启屏幕刷新
MsgBox "已完成"
End Sub

简七

代码审核中

简七

声明了shape对象好像没用

skylake

简七 发表于 2020-11-28 18:04
Sub test()

Application.ScreenUpdating = False '关闭屏幕刷新

这段代码我测试了，也不能完成目的，关闭on error resume next后，Set sh = ThisWorkbook.Sheets("图片" & rng.Value) 就报错了下标越界，因为这时工作簿可能不存在Sheets("图片" & rng.Value)。后面的代码就无法调试哪里会有问题了