excel - 如何独立调整粘贴到工作表的图片大小

Question

我正在寻找一种方法来调整每天修改并粘贴到报告中的表格图片的大小。这是我的目标、问题和建议的解决方案的描述（我不知道如何编码）。

我的目标：我的代码需要 - 1）从表格工作表中复制名为表格 A 的表格的图片，然后 - 2）将表格 A 图片粘贴到输出表上的单元格 B2，然后 - 3）调整粘贴的表格 A图片。稍后，当 - 1) 下一次激活输出表时，要 - 2) 删除输出表上的所有图片，包括粘贴在单元格 B2 中的现有表 A 图片（为简洁起见，此代码已省略），以及 - 3) 复制从表表中新建和更新表 A，然后 - 4) 将新复制的表 A 的图片粘贴到输出表上的 B2，然后 - 5) 将新粘贴的表 A 调整为应用于先前粘贴但现在删除了表 A。 问题：VBA将图片名称作为ShapeRange（比如“Picture 1”或“ShapeRange (1)）分配给原始表格粘贴到输出表的图片，然后在“图片1”被删除后，VBA分配一个不同的名称或 ShapeRange（例如“图片 2”或“ShapeRange (2)）到从表格表复制并粘贴到输出表上相同位置的每个更新的表格 A 的新副本。不幸的是，我的 VBA 图片（或 ShapeRange）大小调整代码无法识别图片名称已更改，因此它将尝试调整“图片 1”（不再存在）的大小，而不是新粘贴的“图 2”。 解析度：我要么需要使每个新图片复制/粘贴到输出表上特定位置的名称始终与先前从同一位置删除的图片名称相同的代码（例如，粘贴到输出表的每个新表 A 总是命名为“图片 1”），或者调整大小代码已更改，因此它可以识别并适用于任何新名称 VBA 分配给每个新复制的表格 A 图片，该图片粘贴到输出表以替换先前删除的图片名称。

对此问题的解决方案将不胜感激？

'Copies TABLE Picture and Pastes on OUTPUT Worksheet
Worksheets("TABLE").Range("a1:O29").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("OUTPUT").Paste _
Destination:=Worksheets("OUTPUT").Range("B2")

'Resizes TABLE Picture on OUTPUT Worksheet
        Dim Shp As Shape
        Dim lWidth As Long, lHeight As Long

            Set Shp = ActiveWindow.Selection.ShapeRange(1)

            lHeight = Shp.Height
            lWidth = Shp.Width

            hp.Height = 3 * 72 * lHeight / lWidth
            Shp.Width = 4.75 * 72

'Copies CHART Picture and Pastes on OUTPUT Worksheet
Worksheets("CHART").Range("A1:j17").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("OUTPUT").Paste _
Destination:=Worksheets("OUTPUT").Range("B18")


End Sub```

标签： excelvbaimageresizeworksheet

Answer 1

好的，现在你的编辑更有意义了。

你提到你想触发它，Worksheet_Activate所以下面是为此事件编写的。

它或多或少是您所写的，但Shapes.Count用作Shapes()集合的索引号。这意味着最近添加的形状将是受我们更改影响的形状。

我添加了一条语句来重命名它（源表的名称），但如果不需要它可以排除。

我还在With语句中首当其冲地包含了代码以缩短我们的代码，因为许多调用都需要工作表限定。

我对此进行了以下测试：

• Worksheets("DATA")被测试为Worksheets("Sheet1")
• Worksheets("OUTPUT")被测试为Worksheets("Sheet2")
• Worksheets("CHART")被测试为Worksheets("Sheet3")

我每次都手动删除了两张图片Sheet2，然后导航离开然后返回Sheet2再次触发代码 - 每次我得到与预期相同的结果（代码下方的屏幕截图）。

我的代码：

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "OUTPUT" Then

    'Copies TABLE Picture and Pastes on OUTPUT Worksheet
    Worksheets("DATA").Range("a1:O29").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Worksheets("OUTPUT").Paste Worksheets("OUTPUT").Range("B2")

    With Worksheets("OUTPUT").Shapes(Worksheets("OUTPUT").Shapes.Count)
        .Name = "DATA"

    'Resizes TABLE Picture on OUTPUT Worksheet
        Dim lWidth As Long, lHeight As Long

        lHeight = .Height
        lWidth = .Width

        .Height = 3 * 72 * lHeight / lWidth
        .Width = 4.75 * 72
    End With

    'Copies CHART Picture and Pastes on OUTPUT Worksheet
    Worksheets("CHART").Range("A1:j17").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Worksheets("OUTPUT").Paste Worksheets("OUTPUT").Range("B18")
End If
End Sub

输出截图：

复制的“DATA”和“CHART”范围内的数据分别填充“Sheet1”和“Sheet3”作为填充数据。

经过多次测试并每次手动删除粘贴的图片，然后再导航到“Sheet2”（“OUTPUT”），这是不变的结果：