cần giúp đở đoạn code xóa ảnh trước đó đã Insert

[hondacrv2019]

Em cần 1 đoạn code hiện hình ảnh vào ô B3 ( Vừa khíp với diện tích ở B3 ) khi thay đổi đường dẫn tại ô B1. Code chạy thì Ok mổi tội là nó không xóa ảnh trước đó thành ra nó tạo nhiều hình ảnh. Mong mọi người giúp đở

Sub InsertPic()
    Dim PicPath As String, Pic As Picture, ImageCell As Range
    PicPath = Range("b1").Value
    Set ImageCell = Range("b3")
    Set Pic = ActiveSheet.Pictures.Insert(PicPath)
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ImageCell.Left
        .Top = ImageCell.Top
        .Width = ImageCell.Width
        .Height = ImageCell.Height
    End With
End Sub

 

[snow25]

Em cần 1 đoạn code hiện hình ảnh vào ô B3 ( Vừa khíp với diện tích ở B3 ) khi thay đổi đường dẫn tại ô B1. Code chạy thì Ok mổi tội là nó không xóa ảnh trước đó thành ra nó tạo nhiều hình ảnh. Mong mọi người giúp đở

Sub InsertPic()
    Dim PicPath As String, Pic As Picture, ImageCell As Range
    PicPath = Range("b1").Value
    Set ImageCell = Range("b3")
    Set Pic = ActiveSheet.Pictures.Insert(PicPath)
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ImageCell.Left
        .Top = ImageCell.Top
        .Width = ImageCell.Width
        .Height = ImageCell.Height
    End With
End Sub

View attachment 217643

Đặt cho nó cái tên rồi xoá là xong à.

 

[hondacrv2019]

Đặt cho nó cái tên rồi xoá là xong à.

Dạ cảm ơn anh. tại em mới tập tành VBA em chưa biết câu lệnh đặt tên và câu lệnh xóa. Mong anh chỉ giáo

 

[giaiphap]

Em cần 1 đoạn code hiện hình ảnh vào ô B3 ( Vừa khíp với diện tích ở B3 ) khi thay đổi đường dẫn tại ô B1. Code chạy thì Ok mổi tội là nó không xóa ảnh trước đó thành ra nó tạo nhiều hình ảnh. Mong mọi người giúp đở

Sub InsertPic()
    Dim PicPath As String, Pic As Picture, ImageCell As Range
    PicPath = Range("b1").Value
    Set ImageCell = Range("b3")
    Set Pic = ActiveSheet.Pictures.Insert(PicPath)
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ImageCell.Left
        .Top = ImageCell.Top
        .Width = ImageCell.Width
        .Height = ImageCell.Height
    End With
End Sub

View attachment 217643

Thử sửa lại thế này.

Sub InsertPic()
On Error Resume Next
    Dim PicPath As String, Pic As Picture, ImageCell As Range
    PicPath = Range("b1").Value
    Set ImageCell = Range("b3")
    ActiveSheet.Pictures("GPE").Delete
    Set Pic = ActiveSheet.Pictures.Insert(PicPath)
    Pic.Name = "GPE"
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ImageCell.Left
        .Top = ImageCell.Top
        .Width = ImageCell.Width
        .Height = ImageCell.Height
    End With
End Sub

 

[hondacrv2019]

Thử sửa lại thế này.

Sub InsertPic()
On Error Resume Next
    Dim PicPath As String, Pic As Picture, ImageCell As Range
    PicPath = Range("b1").Value
    Set ImageCell = Range("b3")
    ActiveSheet.Pictures("GPE").Delete
    Set Pic = ActiveSheet.Pictures.Insert(PicPath)
    Pic.Name = "GPE"
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ImageCell.Left
        .Top = ImageCell.Top
        .Width = ImageCell.Width
        .Height = ImageCell.Height
    End With
End Sub

Trời ời mấy bác GPE quá giỏi. Em xin chân thành cảm ơn !