إضافة صورة متغيرة في خلية تبعاً لقيمة خلية أخرى

[Hamdi Edlbi-khalf]

السلام عليكم

في بعض الأحيان نحتاج إلى عرض صورة في عمود أو خلية  تبعاً لقيمة خلية في عمود آخر أو خلية أخرى

   مثلاً تغيير صورة منتج بناء على اسمه أو كوده و تغيير صورة موظف مع تغير اسمه

الأكواد المستخدمة

   'كود إضافة قائمة منسدلة إلى العمود الذي سيتم تغيير الصور بناء على قيمته 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error Resume Next 

If Target.Column = 1 Then

    With Range("a" & Target.Row).Validation
        .Delete

        'w_r=OFFSET($E$1;0;0;COUNTIF($E$1:$E$1000;"<>"))
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=w_r"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With

End If
End Sub

'إدراج الصور في الخلايا 

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
    Dim PicM As Picture
    Dim pictloc As String
'Created by H-E Khalf
    Dim x As String
 

    If Target.Column = 1 And Range("a" & Target.Row) = "" Then
    
        x = Range("c" & Target.Row).Address & "c"


    ActiveSheet.Shapes(x).Delete
    End If

    If Target.Column = 1 And Range("a" & Target.Row) <> "" Then




        x = Range("c" & Target.Row).Address & "c"


    ActiveSheet.Shapes(x).Delete



    pictloc = Application.ActiveWorkbook.Path & "\" & Range("a" & Target.Row).Value '& ".jpg"



Set PicM = ActiveSheet.Pictures.Insert(pictloc)



PicM.Select

    PicM.ShapeRange.LockAspectRatio = msoFalse
    PicM.ShapeRange.Height = Range("c" & Target.Row).Height
    PicM.ShapeRange.Width = Range("c" & Target.Row).Height



    PicM.Top = Range("c" & Target.Row).Top
    PicM.Left = Range("c" & Target.Row).Left

    PicM.Placement = xlMoveAndSize

   

    PicM.Name = Range("c" & Target.Row).Address & "c"
    Range("a" & Target.Row).Select

End If
Application.ScreenUpdating = True
End Sub

'تصفير البيانات
Private Sub CommandButton1_Click()
Call Del
End Sub

Sub Del()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Excel.Shape
For Each Sh In ActiveSheet.Shapes
If Right(Sh.Name, 1) = "c" Then
Sh.Delete
End If
Next

 Dim Cel As Range
 Dim C As Integer

 For Each Cel In Range("a1:a1000")
With Cel.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
End With
Next

Range("a:a").ClearContents
Range("a:a").ClearHyperlinks
Selection.ClearContents
Selection.ClearHyperlinks
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

' جلب أسماء الصور من المجلد الذي  سيوضع به الملف و هي من لاحقة 
 ' jpg
Private Sub Workbook_Open()
Call Get_Files_Names
End Sub

Sub Get_Files_Names()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim fldpath
Dim fso As Object, fld As Object, fil As Object, j As Long


On Error Resume Next

fldpath = Application.ActiveWorkbook.Path
    If fldpath = False Then
        MsgBox "Folder Not Selected"
        Exit Sub
    End If


Columns("D:D").Clear


Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.getfolder(fldpath)


j = 1
For Each fil In fld.Files
    Range("D" & j).Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fil.Path, _
        TextToDisplay:=fil.Name
        ActiveSheet.Hyperlinks.Delete
        
j = j + 1
Next
Dim Cel As Range
For Each Cel In Range("D1:D1000")
If Right(Cel, 4) <> ".jpg" Then
        Cel.Delete Shift:=xlUp
        End If
        Next
Dim Cel1 As Range
For Each Cel1 In Range("D1:D1000")
If Left(Cel1, 1) = "~" Then
        Cel1.Delete Shift:=xlUp
        End If
        Next
Set fso = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

قمت بكتابة بعض هذه الأكواد بينما اقتصر عملي على تعديل بعضها فقط

و جزى الله خيراً من قدم الأكواد الأصلية.

 احتجت إل هذه الفكرة فاحببت مشاركتها مع من يبحث عنها

إدراج صورة متغيرة حسب قيمة خلية.xlsm

[Ali Mohamed Ali]

أحسنت أستاذ خلف كود ممتاز جعله الله في ميزان حسناتك وكل عام وانتم بخير

[Hamdi Edlbi-khalf]

بارك الله بك و جزاك الله خيراًووفقه عاماً مباركاً و عبادة مقبولة