Chèn hình có điều kiện

[LeMinhhHa]

Mình có học trên Youtube và làm một fie như đính kèm.
Mục đích là khi chọn số CMND tại D7 sheets Form thì hình của người đó hiện ra tại ô F6.
Mình không biết VBA mà chỉ làm theo hướng dẫn nên rất mong anh em giúp đỡ sửa lỗi và giải thích tại sao file của mình không chạy.
Xin chân thành cảm ơn

 

[leonguyenz]

Mình có học trên Youtube và làm một fie như đính kèm.
Mục đích là khi chọn số CMND tại D7 sheets Form thì hình của người đó hiện ra tại ô F6.
Mình không biết VBA mà chỉ làm theo hướng dẫn nên rất mong anh em giúp đỡ sửa lỗi và giải thích tại sao file của mình không chạy.
Xin chân thành cảm ơn

Chỉnh theo code trong file đính kèm.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Picname As String, fRng As Range
Application.ScreenUpdating = False
If Not Intersect([D7], Target) Is Nothing Then
    Set Rng = Sheets("List").Range("B5:B" & Sheets("List").[B65535].End(xlUp).Row)
    Set fRng = Rng.Find(Target, , , 1, , , 1)
    If Not fRng Is Nothing Then
        Picname = ThisWorkbook.Path & "\Foto\" & fRng.Offset(, 5)
        On Error Resume Next
        Sheets("Form").Shapes([F6].Address).Delete
        Sheets("Form").[F6].Seclect
        With ActiveSheet.Pictures.Insert(Picname)
            .Name = [F6].Address
            .Left = [F6].Left: Top = [F6].Top
            .Width = 100
            .Height = 150
        End With
        Activesheets.Shapes("$F$6").IncrementTop = 0
        Activesheets.Shapes("$F$6").IncrementLeft = 0
    End If
End If
Application.ScreenUpdating = True
End Sub

 

[be_09]

Chỉnh theo code trong file đính kèm.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Picname As String, fRng As Range
Application.ScreenUpdating = False
If Not Intersect([D7], Target) Is Nothing Then
    Set Rng = Sheets("List").Range("B5:B" & Sheets("List").[B65535].End(xlUp).Row)
    Set fRng = Rng.Find(Target, , , 1, , , 1)
    If Not fRng Is Nothing Then
        Picname = ThisWorkbook.Path & "\Foto\" & fRng.Offset(, 5)
        On Error Resume Next
        Sheets("Form").Shapes([F6].Address).Delete
        Sheets("Form").[F6].Seclect
        With ActiveSheet.Pictures.Insert(Picname)
            .Name = [F6].Address
            .Left = [F6].Left: Top = [F6].Top
            .Width = 100
            .Height = 150
        End With
        Activesheets.Shapes("$F$6").IncrementTop = 0
        Activesheets.Shapes("$F$6").IncrementLeft = 0
    End If
End If
Application.ScreenUpdating = True
End Sub

Chắc là thế này hình thẻ phải nằm phía trước, và ở Bài này anh nêu ý kiến nhưng không thấy trả lời nên đành cho qua.

 

[LeMinhhHa]

Chỉnh theo code trong file đính kèm.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Picname As String, fRng As Range
Application.ScreenUpdating = False
If Not Intersect([D7], Target) Is Nothing Then
    Set Rng = Sheets("List").Range("B5:B" & Sheets("List").[B65535].End(xlUp).Row)
    Set fRng = Rng.Find(Target, , , 1, , , 1)
    If Not fRng Is Nothing Then
        Picname = ThisWorkbook.Path & "\Foto\" & fRng.Offset(, 5)
        On Error Resume Next
        Sheets("Form").Shapes([F6].Address).Delete
        Sheets("Form").[F6].Seclect
        With ActiveSheet.Pictures.Insert(Picname)
            .Name = [F6].Address
            .Left = [F6].Left: Top = [F6].Top
            .Width = 100
            .Height = 150
        End With
        Activesheets.Shapes("$F$6").IncrementTop = 0
        Activesheets.Shapes("$F$6").IncrementLeft = 0
    End If
End If
Application.ScreenUpdating = True
End Sub

Chỉnh theo code trong file đính kèm.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Picname As String, fRng As Range
Application.ScreenUpdating = False
If Not Intersect([D7], Target) Is Nothing Then
    Set Rng = Sheets("List").Range("B5:B" & Sheets("List").[B65535].End(xlUp).Row)
    Set fRng = Rng.Find(Target, , , 1, , , 1)
    If Not fRng Is Nothing Then
        Picname = ThisWorkbook.Path & "\Foto\" & fRng.Offset(, 5)
        On Error Resume Next
        Sheets("Form").Shapes([F6].Address).Delete
        Sheets("Form").[F6].Seclect
        With ActiveSheet.Pictures.Insert(Picname)
            .Name = [F6].Address
            .Left = [F6].Left: Top = [F6].Top
            .Width = 100
            .Height = 150
        End With
        Activesheets.Shapes("$F$6").IncrementTop = 0
        Activesheets.Shapes("$F$6").IncrementLeft = 0
    End If
End If
Application.ScreenUpdating = True
End Sub

Xin cám ơn Anh Leonguyenz nhiều
Mình sẽ thử