即时调整尺寸并在纸张之间复制图像调整 [英] Copying image between the sheets with instant resizing & adjusting

问题描述

我有问题. 我想在Excel工作表之间复制图像，并立即将其调整到单元格中.

I have got a problem. I would like to copy the image between the Excel sheets and have it adjusted at once to the cells.

到目前为止，我在1张纸上进行了调整，管理得很好

So far I managed perfectly with adjustment on the 1 sheet

  Sub signature()
  Dim myImage As Shape
  Dim imageWidth As Double
  Dim imageHeight As Double

  Set myImage = ActiveSheet.Shapes("Picture 13")
  imageWidth = 170
  imageHeight = 65

  myImage.LockAspectRatio = msoFalse
  myImage.Width = imageWidth
  myImage.Height = imageHeight

  'x:
  myImage.Left = myImage.Left + 650

  'y:
  myImage.Top = myImage.Top - 70

  End Sub

看起来像这样:

为图像分配了ID，如下所示:

To the image is assigned the ID, as shown below:

现在，我想将此图像复制到另外2张纸中，此解决方案可以完成此操作:

Now, I want to copy this image into another 2 sheets, which can be done by this solution:

 Sub signature_copy()
   Sheets("Sign Off Sheet").Shapes("Picture 13").Copy
   Sheets("BoQ Civils").Range("C43").PasteSpecial
   Sheets("BoQ Cabling").Range("C37").PasteSpecial

 End Sub

一切都很好，但是我收到的图像大小相同.

Everything would be fine, but I am receiving an image of the same size.

它必须装有电池.从技术上讲，使用上面的代码并将形状ID更改为新的形状ID是可行的.不幸的是，我无法执行此操作，因为我想使用一张图像并复制并复制它.在所有工作表中立即调整大小.

It has to be fitted with the cells. Technically it's feasible by using the code above and changing the shape ID into the new one copied. Unfortunately, I can't do this, since I would like to use one image and make it copied & resized instantly in all sheets.

我应该怎么做才能达到这个目标?

What should I do to receive this goal?

推荐答案

Sheets(签名表").Shape(图片13").Copy

Sheets("Sign Off Sheet").Shapes("Picture 13").Copy

Sheets("BoQ Civils").Range("C43").PasteSpecial

Sheets("BoQ Civils").Range("C43").PasteSpecial

使用对象.处理它们会更容易

Work with Objects. It will be easier to handle them

尝试

Option Explicit

Sub Sample()
    Dim shpA As Shape, shpB As Shape
    Dim rng As Range
    
    Set shpA = Sheets("Sign Off Sheet").Shapes("Picture 13")
    shpA.Copy
    
    Set rng = Sheets("BoQ Civils").Range("C43")
    Sheets("BoQ Civils").Paste Destination:=rng
    
    Set shpB = Sheets("BoQ Civils").Shapes("Picture 13")
    
    With shpB
        .Top = rng.Top
        .Left = rng.Left
        .Width = rng.Width
        .Height = rng.Height
    End With
End Sub

编辑:如果形状名称在复制后重新命名，请使用Sheets("BoQ Civils").Shapes.Count按照聊天中建议的@Plutian处理形状

Edit: If the shape name is getting renamed after copying it across then use Sheets("BoQ Civils").Shapes.Count to work with the shape as @Plutian suggested in the chat

Set shpB = Sheets("BoQ Civils").Shapes(Sheets("BoQ Civils").Shapes.Count)

这篇关于即时调整尺寸并在纸张之间复制图像调整的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！