|
楼主 |
发表于 2020-1-21 08:13
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '单元格变更选择时执行 Application.EnableEvents = False '开启代码只执行一次 Dim i, cou1, Arr, str On Error Resume Next '忽略运行出现的错误 Application.ScreenUpdating = False '关闭工作表更新,提高运行速度 Set mysheet1 = ThisWorkbook.Worksheets("Sheet1") cou1 = mysheet1.Shapes.Count '统计工作表里边图形数量 mysheet1.Cells(1, 3) = "" '清空C1单元格里面的数值 If cou1 > 0 Then '如果图形数量大于1,则执行 For i = 1 To cou1 If mysheet1.Shapes(i).Top = mysheet1.Cells(1, 1).Top And _ mysheet1.Shapes(i).Left = mysheet1.Cells(1, 1).Left Then mysheet1.Shapes(i).Delete '如果是图形的位置,则删除图形 End If Next End If If Target.Column = 1 And Target.Columns.Count = 1 And Target.Value <> "" Then '如果选择第一列且只有1个单元格(不为空白),则执行 Arr = Array(".jpg", ".jpeg", ".png", ".bmp", ".gif", ".tif") '图片格式集合 For Each x In Arr '执行图片格式组里面的每一个尝试 str = ThisWorkbook.Path & "\风景\" & Target.Value & x '图片路径 If Dir(str) <> "" Then '如果图片存在,则执行 mysheet1.Pictures.Insert(str).Select '插入图片 With Selection.ShapeRange .LockAspectRatio = msoFalse '不锁定图片的比例 .Height = mysheet1.Cells(1, 3).Height '图片的高度设为单元格高度 .Width = mysheet1.Cells(1, 3).Width .Top = mysheet1.Cells(1, 3).Top '图片的位置为单元格C1到顶部的距离 .Left = mysheet1.Cells(1, 3).Left '图片的位置置为单元格C1到左侧的距离 End With Exit For '导入图片后,退出For循环 Else mysheet1.Cells(1, 3) = "相片不存在" '否则将显示照片不存在 End If Next End If Target.Select '追踪单元格选择 Application.EnableEvents = True '恢复代码只执行一次 Application.ScreenUpdating = True '恢复更新显示 End Sub |
|