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

Question

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

MY OBJECTIVE: 我的代码需要 - 1) 从 TABLE 工作表，然后 - 2) 将 TABLE A 图片粘贴到输出 Sheet 上的单元格 B2，然后 - 3) 调整粘贴的 TABLE A 图片的大小。稍后，当 - 1) OUTPUT Sheet 下一次激活时，到 - 2) 删除 OUTPUT Sheet 上的所有图片，包括现有的 TABLE 粘贴在单元格 B2 中的图片（此代码具有为简洁起见被省略），并且 - 3）从 TABLE Sheet 复制一个新的和更新的 TABLE A，然后 - 4）粘贴新复制的 TABLE A 的图片到 OUTPUT Sheet 上的 B2，然后 - 5) 将新粘贴的 TABLE A 调整为应用于先前粘贴但现在已删除的 TABLE A 的确切尺寸。问题：VBA 将图片名称作为 ShapeRange（比如“图片 1”或“ShapeRange (1)）分配给原始 TABLE 粘贴到输出的图片 Sheet，然后在删除“图片 1”后，VBA 为每个更新的 TABLE A 从 TABLE Sheet 复制并粘贴到 OUTPUT Sheet 上的相同位置。不幸的是，我的 VBA 图片（或 ShapeRange）调整大小代码无法识别图片名称已更改，因此它将尝试调整“图片 1”（不再存在）的大小，如本例所示新粘贴的“图片 2”。 解决方案： 我要么需要代码使每张新图片的名称 copy/pasted 成为OUTPUT Sheet 上的特定位置始终与先前从同一位置删除的图片名称相同（例如，每个新的 TABLE A 粘贴到 OUTPUT Sheet 始终命名为“图片 1” ), 或者更改大小调整代码，使其识别并适用于任何新名称 VBA 分配给每个新复制的 TABLE 粘贴到 OUTPUT Sheet 的图片替换先前删除的图片图片的名称。

如果能解决此问题，将不胜感激？


'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```

Answer 1

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

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

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

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

我还在 With 语句中包含了代码的首当其冲，以缩短我们的代码，因为许多调用需要 sheet 资格。

我对此进行了测试，但存在以下差异：

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"）这是不变的结果：

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

How can I independently resize Pictures pasted to a Worksheet

excel

vba

resize

image

worksheet

我的代码：

输出截图：