Question

我一直在运行剪切和粘贴图片例程一段时间，突然Excel开始给我这个运行时错误。它已经工作了好几天直到现在（没有操作系统更新或重新启动，虽然我尝试关闭并重新打开Excel以查看它是否有帮助）。更奇怪的是，脚本执行批量复制和粘贴。图片，相同的范围（重新计算的值）被复制并粘贴13次，错误信息通常在最后一个循环或偶尔在某个随机点弹出。

我查了一下support.microsoft.com/en-us/kb/905164： “如果满足以下任一条件，则可能会出现此问题：

The Microsoft Visual Basic for Applications (VBA) macro copies and pastes one whole row in an Excel 2003 workbook.
The Microsoft VBA macro copies and pastes a range of 2,516 rows or more rows in an Excel 2003 workbook."

然而，我正在复制一系列12,12个单元格，从A1到L12，确切地说，甚至不是接近整行。我尝试过使用range.offset，xldown，rannge（cells（1,1），cells（12,12））但这些都没有帮助。

有没有人经历过类似的事情？

Sub PutPic(ByRef FN As String)


 Dim fname As String
 fname = "E:\Users\ABCD\Documents\EFGH\" & FN
 Worksheets(2).Range(Cells(1, 1), Cells(12, 12)).Select
 'Sheets("sheet2").Range("A1:l12").Select
 Selection.Copy
 'Sheets("sheet2").Range("a1").Select
 ActiveSheet.Pictures.Paste(Link:=False).Select
 Selection.Name = "Pic"
 Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
 Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromMiddle

 Dim ChtObj As ChartObject
 With ThisWorkbook.Worksheets(2)
    .Activate
    Set ChtObj = .ChartObjects.Add(100, 100, 400, 400)
    ChtObj.Name = "PicFrame"
    ChtObj.Width = .Shapes("Pic").Width
    ChtObj.Height = .Shapes("Pic").Height

    ActiveSheet.Shapes.Range(Array("Pic")).Select
    Selection.Copy

    ActiveSheet.ChartObjects("PicFrame").Activate
    ActiveChart.Paste

    ActiveChart.Export Filename:=fname, FilterName:="png"
    ChtObj.Delete
    ActiveSheet.Shapes.Range(Array("Pic")).Delete

 End With
End Sub

具有循环例程的sub，完全普通，将文件名提供给子例程。

Public Sub MainRun()
 Dim i, j, k As Long
 Dim NMG, NMB As String

 Dim FNGBSig As String
 Dim FNUnivSig As String
 Dim BatchStart, Batch As Long
 BatchStart = ThisWorkbook.Worksheets(2).Cells(15, 1).Value + 1
 Batch = 13
 For i = BatchStart To BatchStart + Batch - 1

'Some calculations that refresh values in range A1:L12

FNGBSig = i & "GoodBad.png"

        PutPic FNGBSig

 Next i

End Sub

Answer 1

我怀疑循环导致问题，因为.Export方法正在运行。使用WinAPI Sleep函数插入一个小延迟（1秒可能就足够了）。另外，我已经清理了一点代码：

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For use in timer function

Sub PutPic(FN)

Dim fname As String
Dim shp As Picture
Dim ChtObj As ChartObject
Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets(2)

fname = "E:\Users\ABCD\Documents\EFGH\" & FN

'Copy the range of cells
With ws
    .Range(.Cells(1, 1), .Cells(12, 12)).Copy

    'Paste & get a handle on the resulting picture:
    Set shp = .Pictures.Paste(Link:=False)
End With

'Scale your picture:
With shp
    .ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
    .ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromMiddle
End With

'Add the ChtObj frame:
Set ChtObj = ws.ChartObjects.Add(100, 100, 400, 400)
'Size the chart, paste the picture in the chart, export
With ChtObj
    .Width = shp.Width
    .Height = shp.Height
    shp.Copy
    Sleep 1000  '1000 milliseconds = 1 second
    .Chart.Paste
    .Chart.Export Filename:=fname, FilterName:="png"
    .Delete
End With

shp.Delete

End Sub

请注意，这通常不赞成：

 Dim i, j, k As Long
 Dim NMG, NMB As String

 Dim FNGBSig As String
 Dim FNUnivSig As String
 Dim BatchStart, Batch As Long

这声明i as Variant, j as Variant, k as Long等。要内联执行多个声明，您仍需要指定数据类型：

Dim i as Long, j as Long, k as Long
Dim NMG as String, NMB as String
' etc...

Excel 2010 VBA：运行时错误1004，Microsoft Excel无法粘贴数据

1 个答案: