كود استدعاء بيانات من القائمة المنسدلة

[سماح الهياتمى]

ارجو عمل كود لاستدعاء البيانات من ورقة ( اعاقات خاصة ) الى ورقة ( تقرير بحالات الاعاقة ) حسب الاختيار الموجود بالقئمة المنسدلة فى اعلى صغحة التقرير

9.rar

[سماح الهياتمى]

للرفع

[سماح الهياتمى]

ارجو من الاخوة الاساتذة الرد على موضوعى

[سماح الهياتمى]

للرفع

[سماح الهياتمى]

برجاء تعديل الكود للاهمية وشكرا لكم 

[سماح الهياتمى]

السادة الخبراء برجاء عمل الكود المطلوب ولكم تحياتى

[ابراهيم الحداد]

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

استخدمى هذه الاكواد الثلاثة

Sub Get_Data()
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long
Dim PatName As String

Set ws = Sheets("تقرير بحالات الاعاقة")
ws.Range("B5:I1000").ClearContents
PatName = ws.Range("D2").Value
Set Sh = Sheets("اعاقات خاصة")
LR = Sh.Range("C" & Rows.Count).End(xlUp).Row
Arr = Sh.Range("B3:I" & LR).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 4) = PatName Then
p = p + 1
For j = 1 To UBound(Arr, 2)
Temp(p, j) = Arr(i, j)
'Temp(p, 1) = p
Next
End If
Next
If p > 0 Then ws.Range("B5").Resize(p, UBound(Temp, 2)).Value = Temp
Call Get_Photo
End Sub
Sub Get_Photo()
Application.ScreenUpdating = False
Dim StudName As String, E As String, Dpath As String
Dim pics As Object
Dim Sh As Worksheet
Dim C As Range, H
Application.ScreenUpdating = False
Set Sh = Sheets("تقرير بحالات الاعاقة")
For Each pics In Sh.Pictures
pics.Delete
Next pics
On Error Resume Next
For Each C In Sh.Range("J5:J1000")
StudName = C.Offset(0, -8).Value
If C.Offset(0, -8).Value <> "" Then
Dpath = ActiveWorkbook.Path
myDir = Dpath & "\" & "صور" & "\"
E = ".jpg"
Sh.Shapes.AddPicture Filename:=myDir & StudName & E, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=C.Left, _
Top:=C.Offset(0, 8).Top, Width:=C.Offset(0, 8).Width, Height:=C.Offset(0, 8).Height
End If
Next
Application.ScreenUpdating = True

End Sub
Sub Delete2_Photos()
Application.ScreenUpdating = False
Dim pics As Object
Dim ws As Worksheet
Set ws = Sheets("تقرير بحالات الاعاقة")
For Each pics In ws.Pictures
    pics.Delete
Next pics
Application.ScreenUpdating = True
End Sub

 

[سماح الهياتمى]

شكرا لرد حضرتك ولكن اريد ان ينفذ على الملف المرفق لو تكرمت حضرتك

لانى لم يجدى نفعا معى

تحياتى

[Ali Mohamed Ali]

تفضل بعد اذن استاذى ابراهيم

 

كود استدعاء بيانات من القائمة المنسدلة.rar