كود لاستراد الصورة ثم ترحيلها من شيت الى شيت آخر

[ابواسماء ابوزيد]

اساتذتى الافاضل المطلوب كود يقوم باستيراد الصورة المرفقة فى شيت ادخال البيانات ثم ترحل  الى شيت طباعة البيانات

الجمعيه الخيريه.xlsb

[محمد هشام.]

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

لجلب الصور دفعة واحدة يكفي الوقوف بمؤشر الماوس على اول خلية فارغة على عمود الصور وتشغيل الكود التالي مع تحديد الصور المرغوب اظافتها 

Sub InsertMultiplePictures() 'اظافة الصور'
Set WS = Sheets("ادخال البيانات")
Dim Pictures() As Variant
Dim j As String, Rng As Range, Cpt As Shape
On Error Resume Next
Pictures = Application.GetOpenFilename(j, MultiSelect:=True)
a = Application.ActiveCell.Column
If IsArray(Pictures) Then
    Col = Application.ActiveCell.Row
    For lLoop = LBound(Pictures) To UBound(Pictures)
        Set Rng = Cells(Col, a)
        Set Cpt = WS.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        Col = Col + 1
    Next
End If
End Sub

لافراغ عمود الصور 

Sub DeleteImage()
Dim pic As Picture
Set f = Sheets("ادخال البيانات")
For Each pic In WS.Pictures
    If Not Application.Intersect(pic.TopLeftCell, f.Range("G6:G200")) Is Nothing Then
        pic.Delete
    End If
Next pic
End Sub

الجدول 1 

=INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$10;'ادخال البيانات'!$B$6:$B$2000;0);6)

 

=MyPicture

 

الجدول 2

 

=INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$36;'ادخال البيانات'!$B$6:$B$2000;0);6)

=MyPicture2

واخيرا ربط الصور بالنطاق 

 

الجمعيه الخيريه 2.xlsb

[ابواسماء ابوزيد]

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

تم تعديل مارس 24 بواسطه ابواسماء ابوزيد

[ابواسماء ابوزيد]

استاذى الفاضل محمد هشام عند تشغيل هذا الكود ظهر رساله خطأ

[محمد هشام.]

قم بتعديل هذا السطر 
For Each pic In WS.Pictures
الى
For Each pic In f.Pictures

 

تم تعديل مارس 25 بواسطه محمد هشام.

[ابواسماء ابوزيد]

في ٢٤‏/٣‏/٢٠٢٤ at 04:27, محمد هشام. said:

 تمام استاذنا الفاضل بارك الله فيكم  وزادكم الله نوراً وسروراً تم التعديل واشتغل الكود تمام