Giúp sửa lỗi ảnh tự thay đổi!!

[N Khánh]

Mình có code chèn ảnh vào như thế này. Ảnh mình để ở B2, đường dẫn thì để ở F2, cái đường dẫn và tên ảnh này luôn cố định.
Nhưng mà hiện tại có 1 lỗi là sau khi chèn ảnh xong. Khi thay đổi ảnh thì file excel cũ khi mở lại cũng nhận theo ảnh mới, mà không lưu được ảnh cũ theo file excel đó. Giờ có cách nào mà khi chèn ảnh xong đóng lưu file excel thì cái ảnh đó sẽ đi theo file excel đó không ạ. Nếu sửa đc vào code thì tốt quá, nếu không thì sửa bằng tay cũng đc. Mình đã thử khi làm xong xóa hàm, xóa đường dẫn mà nó vẫn cứ nhận được theo ảnh mới. Mong các bác giúp mình với !!!

Function supersheeta(ByVal PictureFileName As String, Optional ByVal TargetCell As Range) As String
  On Error Resume Next
  If TargetCell Is Nothing Then Set TargetCell = Application.ThisCell
    TargetCell.Worksheet.Shapes(TargetCell.Address).Delete
    If CreateObject("Scripting.FileSystemObject").fileExists(PictureFileName) Then
        TargetCell.Select
        With TargetCell.Worksheet.Pictures.Insert(PictureFileName)
            .Name = TargetCell.Address
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = TargetCell.Left
            .Top = TargetCell.Top
            .Width = 319
            .Height = 246
        End With
    End If
End Function

 

[N Khánh]

Có ai giúp mình với

 

[excel_lv1.5]

Mình có code chèn ảnh vào như thế này. Ảnh mình để ở B2, đường dẫn thì để ở F2, cái đường dẫn và tên ảnh này luôn cố định.
Nhưng mà hiện tại có 1 lỗi là sau khi chèn ảnh xong. Khi thay đổi ảnh thì file excel cũ khi mở lại cũng nhận theo ảnh mới, mà không lưu được ảnh cũ theo file excel đó. Giờ có cách nào mà khi chèn ảnh xong đóng lưu file excel thì cái ảnh đó sẽ đi theo file excel đó không ạ. Nếu sửa đc vào code thì tốt quá, nếu không thì sửa bằng tay cũng đc. Mình đã thử khi làm xong xóa hàm, xóa đường dẫn mà nó vẫn cứ nhận được theo ảnh mới. Mong các bác giúp mình với !!!

Function supersheeta(ByVal PictureFileName As String, Optional ByVal TargetCell As Range) As String
  On Error Resume Next
  If TargetCell Is Nothing Then Set TargetCell = Application.ThisCell
    TargetCell.Worksheet.Shapes(TargetCell.Address).Delete
    If CreateObject("Scripting.FileSystemObject").fileExists(PictureFileName) Then
        TargetCell.Select
        With TargetCell.Worksheet.Pictures.Insert(PictureFileName)
            .Name = TargetCell.Address
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = TargetCell.Left
            .Top = TargetCell.Top
            .Width = 319
            .Height = 246
        End With
    End If
End Function

Trước khi đóng file bạn chạy code này :

Sub a()
Dim pic As Picture
For Each pic In ActiveSheet.Pictures
    If pic.Name Like "*$*$*" Then
        pic.Copy
        Range(pic.Name).Select
        ActiveSheet.Pictures.Paste
        pic.Delete
    End If
Next
End Sub

 

[N Khánh]

Trước khi đóng file bạn chạy code này :

Sub a()
Dim pic As Picture
For Each pic In ActiveSheet.Pictures
    If pic.Name Like "*$*$*" Then
        pic.Copy
        Range(pic.Name).Select
        ActiveSheet.Pictures.Paste
        pic.Delete
    End If
Next
End Sub

Bác đúng là cứu tinh <3 cảm ơn bác nhiều nhiều lắm ^^

 

[ndu96081631]

Trước khi đóng file bạn chạy code này :

Sub a()
Dim pic As Picture
For Each pic In ActiveSheet.Pictures
    If pic.Name Like "*$*$*" Then
        pic.Copy
        Range(pic.Name).Select
        ActiveSheet.Pictures.Paste
        pic.Delete
    End If
Next
End Sub

Thấy vầy cũng được:

Sub Test()
  ActiveSheet.UsedRange.Replace "=SUPERSHEETA(", "'=SUPERSHEETA(", xlPart, , False
End Sub

 

[N Khánh]

Thấy vầy cũng được:

Sub Test()
  ActiveSheet.UsedRange.Replace "=SUPERSHEETA(", "'=SUPERSHEETA(", xlPart, , False
End Sub

em cảm ơn nhiều ạ ^^