在VBA中移动单元格之间的图像

Question

我有一张图片在单元格（3,1）中，想把它移动到单元格（1,1）。

这是我的代码:

ActiveSheet.Cells(1, 1).Value = ActiveSheet.Cells(3, 1).Value
ActiveSheet.Cells(3, 1).Value = ""

然而，对于包含图像的单元格，单元格的值似乎为空，因此图像未被移动，且单元格（3,1）中的图像未被删除。运行代码时没有任何反应。

非常感谢您的帮助。

谢谢。

- Tim

Answer 1

你的代码问题之一是你将图像视为单元格的值。但是，尽管该图像似乎位于单元格中，但它实际上不是单元格的值。

要移动图像，你可以通过相对方式（使用Shape.IncrementLeft或Shape.IncrementRight）或绝对方式（通过设置Shape.Left和Shape.Top的值）来移动图像。

在下面的示例中，我演示了如何将形状移动到新的绝对位置，无论是否保留原始单元格的缩进（如果不保留原始缩进，则只需将Shape的Top和Left值设置为目标Range的值即可）。

此过程接受形状名称（可以通过多种方式找到形状名称；我的方法是记录一个宏，然后单击形状并移动它以查看所生成的代码）、目标地址（例如"A1"）和（可选的）布尔值，指示是否要保留原始缩进偏移量。

Sub ShapeMove(strShapeName As String, _
    strTargetAddress As String, _
    Optional blnIndent As Boolean = True)
Dim ws As Worksheet
Dim shp As Shape
Dim dblCurrentPosLeft As Double
Dim dblCurrentPosTop As Double
Dim rngCurrentCell As Range
Dim dblCurrentCellTop As Double
Dim dblCurrentCellLeft As Double
Dim dblIndentLeft As Double
Dim dblIndentTop As Double
Dim rngTargetCell As Range
Dim dblTargetCellTop As Double
Dim dblTargetCellLeft As Double
Dim dblNewPosTop As Double
Dim dblNewPosLeft As Double

'Set ws to be the ActiveSheet, though this can really be any sheet      '
Set ws = ActiveSheet

'Set the shp variable as the shape with the specified shape name  '
Set shp = ws.Shapes(strShapeName)

'Get the current position of the image on the worksheet                 '
dblCurrentPosLeft = shp.Left
dblCurrentPosTop = shp.Top

'Get the current cell range of the image                                '
Set rngCurrentCell = ws.Range(shp.TopLeftCell.Address)

'Get the absolute position of the current cell                          '
dblCurrentCellLeft = rngCurrentCell.Left
dblCurrentCellTop = rngCurrentCell.Top

'Establish the current offset of the image in relation to the top left cell'
dblIndentLeft = dblCurrentPosLeft - dblCurrentCellLeft
dblIndentTop = dblCurrentPosTop - dblCurrentCellTop

'Set the rngTargetCell object to be the address specified in the paramater '
Set rngTargetCell = ws.Range(strTargetAddress)

'Get the absolute position of the target cell       '
dblTargetCellLeft = rngTargetCell.Left
dblTargetCellTop = rngTargetCell.Top

'Establish the coordinates of the new position. Only indent if the boolean '
' parameter passed in is true. '
' NB: The indent can get off if your indentation is greater than the length '
' or width of the cell '
If blnIndent Then
    dblNewPosLeft = dblTargetCellLeft + dblIndentLeft
    dblNewPosTop = dblTargetCellTop + dblIndentTop
Else
    dblNewPosLeft = dblTargetCellLeft
    dblNewPosTop = dblTargetCellTop
End If

'Move the shape to its new position '
shp.Top = dblNewPosTop
shp.Left = dblNewPosLeft

End Sub

注意：我用一种非常功能化的方式编写了代码。如果您想要“清理”这段代码，最好将功能放在一个对象中。无论如何，希望它能帮助读者理解Excel中形状的工作方式。

- Ben McCormack

---

很好，如果我使用false，它可以处理奇怪/随机大小的缩进。 - egmfrs

Answer 2

一个快速而简单的方法：

Public Sub Example()
    MoveShape ActiveSheet.Shapes("Picture 1"), Range("A1")
End Sub

Private Sub MoveShape(ByVal shp As Excel.Shape, ByVal target As Excel.Range)
    shp.IncrementLeft -(shp.TopLeftCell.Left - target.Left)
    shp.IncrementTop -(shp.TopLeftCell.Top - target.Top)
End Sub

- Oorang

---

非常简单易懂，但是使用时会出现目标单元格左上角的随机缩进大小。 - egmfrs