如何可以删除指定单元格里的图片
Sub 删除()
dim x as Integer
For x = 1 To Sheet1.Shapes.Count
If Sheet1.Shapes(x).TopLeftCell.Address = "$A$1" Then
Sheet1.Shapes(x).Delete
End If
Next x
End Sub
如果有多个图片:
Sub 删除()
dim x as Integer
For x = Sheet1.Shapes.Count To 1 step -1
If Sheet1.Shapes(x).TopLeftCell.Address = "$A$1" Then
Sheet1.Shapes(x).Delete
End If
Next x
End Sub
如何在EXCEL中动态的显示图片,要求如下:
1.在某一CELL中输入图片的绝对路径,移开焦点后,在该cell中自动显示图片,并且图片可根据列的大小自动适应.
请高手帮忙!!
请问EXCEL能做到吗??
Private Sub Worksheet_Change(ByVal Target As Range)
Dim a As Shape, r As Single
If Dir(Target.Text) <> "" Then
ActiveSheet.Pictures.Insert(Target.Text).Select
Selection.ShapeRange.Top = Target.Top
Selection.ShapeRange.Left = Target.Left
r = Target.Width / Selection.ShapeRange.Width
Selection.ShapeRange.ScaleWidth r, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight r, msoFalse, msoScaleFromTopLeft
Rows(Target.Row).RowHeight = Selection.ShapeRange.Height
Selection.Placement = xlMoveAndSize
Selection.PrintObject = True
Target.Select
End If
End Sub
最佳效果CODE:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Len(Target.Text) = 0 Then Exit Sub
Dim sngLeft As Single, sngTop As Single, sngRight As Single, sngBottom As Single, sngScale As Single
Dim rngCell As Range, rngCellBR As Range, shp As Shape, tmp
If Dir(Target.Text) <> "" Then
Set rngCell = Target.Offset(0, 1)
Set rngCellBR = rngCell.Offset(1, 1)
sngTop = rngCell.Top
sngLeft = rngCell.Left
sngRight = rngCellBR.Left
sngBottom = rngCellBR.Top
For Each shp In ActiveSheet.Shapes
If shp.Top >= sngTop - 5 And shp.Top < sngBottom - 5 And shp.Left >= sngLeft - 5 And shp.Left < sngRight - 5 Then
shp.Delete
Exit For
End If
Next shp
rngCell.Select
On Error GoTo ErrorHandler
ActiveSheet.Pictures.Insert(Target.Text).Select
Set shp = Selection.ShapeRange(1)
shp.Top = rngCell.Top
shp.Left = rngCell.Left
sngScale = rngCell.Width / shp.Width
shp.ScaleWidth sngScale, msoFalse, msoScaleFromTopLeft
shp.ScaleHeight sngScale, msoFalse, msoScaleFromTopLeft
rngCell.Rows.RowHeight = shp.Height
shp.Placement = xlMoveAndSize
ErrorHandler:
Set shp = Nothing
Set rngCell = Nothing
Set rngCellBR = Nothing
Set Target = Nothing
End If
End Sub
找出某目录下所有文件的名称:
Private Sub Workbook_Open()
f = Dir("T:/xyz/*")
Do While f <> ""
r = r + 1
Cells(r, 1) = f
f = Dir
Loop
End Sub