مساعدة في استراد الصورة الى الخلية

[حراثي تواتي]

السلام عليكم ورحمة الله وبركاته

رمضان كريم على الامة الاسلامية

التمس منكم مساعدة بخصوص اي طريقة يمكن بواسطها استدعاء الصورة سواء من الملف او من اليوزر فورم الى خلية محددة في الشيت

حفظ الصورة.rar

[حراثي تواتي]

هل من مساعد ؟؟ جزاكم الله خير

[حراثي تواتي]

رمضان كريم

[حراثي تواتي]

 

هل من مساعد ؟؟ جزاكم الله خير

[حراثي تواتي]

؟؟؟؟؟؟؟؟؟؟؟

في حاجة ماسة اليه وشكرا مسبقا

[حراثي تواتي]

رمضان كريم

[Hamdi Edlbi-khalf]

السلام عليكم

انظر في هذا الرابط ستجد فيه حاجتك و أعتذر لا أستطيع التعديل على ملفك كوني اتصل من الجوال 

 

[حراثي تواتي]

بارك الله فيك أخي 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

 

حفظ الصورة.rar

[احمد بدره]

ممكن تجربة هذا الكود

بيان الموظفين.xlsm

[حراثي تواتي]

تمام يا رايس بالضبط هذا ما كنت ابحث عنه بارك الله فيك وفي اهلك واولادك وفي مالك واسعدك الله في الدارين

شكرا شكرا أخي

احمد بدره

تم تعديل مايو 28, 2019 بواسطه حراثي تواتي