[已解决]请教各位老师，怎样利用VBA提取相片到指定位置？谢谢

huangjinyui

请教各位老师，怎样利用VBA提取相片到指定位置？谢谢

最佳答案

月排行榜 / 总排行榜

苏子龙

2016-9-23 11:48

huangjinyui 发表于 2016-9-23 08:51
谢谢老师，不过在运行时好像出现了些问题，麻烦老师帮我继续完善下，谢谢

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rg As Range, picPth As String
    Dim shp As Object
    With Target
        If .Count > 1 Then Exit Sub
        If .Address <> "$AI$3" Then Exit Sub
    End With
    On Error GoTo er
    Set rg = Range("x4").MergeArea
    picPth = ThisWorkbook.Path & "\" & Range("e4") & ".jpg"
   
    For Each shp In ActiveSheet.Shapes
        If shp.Top = rg.Top Or shp.Left = rg.Left Then shp.Delete
    Next shp
   
    ActiveSheet.Shapes.AddPicture picPth, True, True, _
        rg.Left, rg.Top, rg.Width, rg.Height
        Exit Sub
        
er:
        MsgBox "没找到图片或者名称不对", , "提示"
End Sub
改了下

跳转到最佳答案楼层

huangjinyui

各位老师可以帮个忙吗？谢谢

苏子龙

试试这个

huangjinyui

苏子龙 发表于 2016-9-22 23:52
试试这个

谢谢老师，不过在运行时好像出现了些问题，麻烦老师帮我继续完善下，谢谢

su45

新建文件夹 (2).zip (50.85 KB, 下载次数: 8)

2016-9-23 09:33 上传

点击文件名下载附件

苏子龙

huangjinyui 发表于 2016-9-23 08:51
谢谢老师，不过在运行时好像出现了些问题，麻烦老师帮我继续完善下，谢谢

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rg As Range, picPth As String
    Dim shp As Object
    With Target
        If .Count > 1 Then Exit Sub
        If .Address <> "$AI$3" Then Exit Sub
    End With
    On Error GoTo er
    Set rg = Range("x4").MergeArea
    picPth = ThisWorkbook.Path & "\" & Range("e4") & ".jpg"
   
    For Each shp In ActiveSheet.Shapes
        If shp.Top = rg.Top Or shp.Left = rg.Left Then shp.Delete
    Next shp
   
    ActiveSheet.Shapes.AddPicture picPth, True, True, _
        rg.Left, rg.Top, rg.Width, rg.Height
        Exit Sub
        
er:
        MsgBox "没找到图片或者名称不对", , "提示"
End Sub
改了下