时间戳

首页 > 解决方案 > Excel VBA 处理和粘贴许多形状现在在 Windows 10 中出错，但在 2016 年没有

excel - Excel VBA 处理和粘贴许多形状现在在 Windows 10 中出错，但在 2016 年没有

问题描述

我是 VBA 的新手，但总是从阅读论坛中找到解决方案。

我现在有一个无法解决的问题，我的公司最近从 Windows 2016 切换到了 Windows 10（幸运的是，我现在仍然拥有两台笔记本电脑）但是我的代码在一些 Excel VBA 工具中出现不一致错误的问题我已在旧版本中开发。

我的同事也遇到了这个问题，但设法通过禁用和启用丢失的库来解决他的问题。我试过这个但没有解决。

错误..

基本上我的工具通过复制和粘贴形状、调整它们的大小并在指定的单元格位置重命名它们来“绘制”项目的甘特视图。以前的版本完全没有问题需要几秒钟。Windows 10 完全不一致。有时它将毫无问题地运行（比如 20% 的时间），然后它会在代码的完全不同区域出错！

我得到的错误是“工作表类的运行时错误 1004 粘贴方法失败”

我不确定为什么我的代码会在旧 Windows 而不是 Windows 10 中运行 find .. 但这可能是因为我的代码有点垃圾并且选择了形状和单元格等，它有时无法应对？

这是我正在使用的代码示例，任何建议将不胜感激：

Sub DrawDevelopment()

Dim rngData As Range

Set rngData = Sheets("Gantt Extract").Range("a4:a300")

    For Each G In rngData


        G_Address = G.Offset(0, 39).Value
        G_size = G.Offset(0, 40).Value
        G_Scheme = G.Offset(0, 1).Value

        If G_Address <> "" Then

            Sheets("Gantt").Shapes("Development").Select
            Selection.Copy
            Range(G_Address).Select
            Sheets("Gantt").Paste
            Selection.Name = "Delete" & (G_Scheme)
            With Selection.ShapeRange
                .Width = G_size
            Selection.ShapeRange.IncrementTop 4
    
            Selection.ShapeRange.ZOrder msoBringToFront
                
           End With
        End If

    Next G
    

End Sub

使用形状绘制的整体代码示例

标签： excelvba

解决方案

Select虽然并非特定于 Windows 10，但在此处使用不合格语句可能会导致问题。

我试过在没有 - 的情况下重写它，Select但为了测试它，我还必须ShapeRange在它与我的形状一起使用之前去掉它的用法。

可能有更好的方法来引用粘贴的形状，但我无法立即看到，所以这看起来有点乱，但适用于我的 Win10 机器：

Sub DrawDevelopment()

    Dim rngData As Range
    
    Dim shtCopyFrom As Worksheet
    Dim shtCopyTo As Worksheet
    
    Set shtCopyFrom = Sheets("Gantt")
    Set shtCopyTo = Sheets("Gantt Extract")
    Set rngData = shtCopyTo.Range("a4:a300")
        
    For Each g In rngData.Cells
        G_Address = g.Offset(0, 39).Value
        G_size = g.Offset(0, 40).Value
        G_Scheme = g.Offset(0, 1).Value
        If G_Address <> "" Then
            shtCopyFrom.Shapes("Development").Copy
            With shtCopyTo
                .Paste
                Set objShape = .Shapes(.Shapes.Count)
                objShape.Name = "Delete" & (G_Scheme)
                Set pasteCell = .Range(G_Address)
                With objShape
                    .Width = G_size
                    .IncrementTop 4
                    .ZOrder msoBringToFront
                    .Left = pasteCell.Left
                    .Top = pasteCell.Top
                End With
            End With
        End If
    Next g
End Sub

推荐阅读