عبدالله المجرب

وهذا التعديل ليتم اضافة نوع الصورة Function INSERTPICTURE(ByVal PictureFullName As String, MyType As String, Optional ByVal PicWidth As Single = 200, _ Optional ByVal PicHeight As Single = 150) Dim CellActive As Range Dim picPicture As Object MyName = "C:\Pictures\" Set CellActive = Application.Caller For Each picPicture In CellActive.Parent.Pictures If picPicture.TopLeftCell.Address = CellActive.Address Then picPicture.Delete Exit For End If Next Set picPicture = CellActive.Parent.Pictures.Insert(MyName & PictureFullName & "." & MyType) With picPicture .Left = CellActive.Left + 1 .Top = CellActive.Top + 1 .Width = PicWidth .Height = PicHeight End With End Function لتصبح الدالة =INSERTPICTURE("Penguins";"jpg")

السلام عليكم الدالة تعمل بكفاءة 2007 == قمت بعد اذن الاستاذ ياسر خليل بتعديل على الدالة لتصبح دون الحاجة الى كتابة المسار وانما اسم الصورة فقط Function INSERTPICTURE(ByVal PictureFullName As String, Optional ByVal PicWidth As Single = 200, _ Optional ByVal PicHeight As Single = 150) Dim CellActive As Range Dim picPicture As Object MyName = "C:\Pictures\": MyType = ".jpg" Set CellActive = Application.Caller For Each picPicture In CellActive.Parent.Pictures If picPicture.TopLeftCell.Address = CellActive.Address Then picPicture.Delete Exit For End If Next Set picPicture = CellActive.Parent.Pictures.Insert(MyName & PictureFullName & MyType) With picPicture .Left = CellActive.Left + 1 .Top = CellActive.Top + 1 .Width = PicWidth .Height = PicHeight End With End Function لتصبح الدالة هكذا =INSERTPICTURE("Penguins")

بارك الله فيك استاذ ابو نصار على هذا التميز

السلام عليكم قمت بوضع تعديل الكود وعمل بكل سلاسة (جربته على ورقة 13 ) سيعمل الكود عند الاختيار من القائمة المنسدلة إضعط هنا

السلام عليكم كنت قد اعددت دالة معرفة ارفقها لاثراء الموضوع Function MySr(MyTbl As Range, MyDat As Date, MyVal1 As Variant, MyVal2 As Variant, col_indx As Integer) Dim R As Boolean, MyDatf As Date, MyDatT As Date For RR = 1 To MyTbl.Rows.Count On Error GoTo 1 MyDatf = MyTbl.Cells(RR, 1) - 1: MyDatT = MyTbl.Cells(RR, 2) + 1 Do If MyDatf = MyDat Then R = True: Exit Do MyDatf = MyDatf + 1 Loop Until MyDatf = MyDatT If R And MyTbl.Cells(RR, 3) = MyVal1 And MyTbl.Cells(RR, 4) = MyVal2 Then MySr = MyTbl.Cells(RR, col_indx): Exit Function End If 1 Next End Function للدالة 5 متغيرات هي 1. MyTbl جدول البيانات 2. MyDat خانة التاريخ (الشرط الاول في البحث) 3. MyVal1 خانة الاسم (الشرط الثاني للبحث) 4. MyVal2 خانة المادة (الشرط الثالث للبحث) 5. col_indx عمود النتيجة المراد استخراجها (اي ان الدالة تبحث عن اي عمود تتطابق به الشروط الثلاثة) شاهد المرفق search.rar

ابحث عن ساعة وستجد الكثير

الملفات مرفوعة على اليوتيوب

بصراحة لم افهم ضع تفصيل لما تريد مع العلم انه سيتم فصل الموضوع في موضوع منفصل بعد ردك

السلام عليكم اخي يوسف اعذرني لعدم وجود وقت لدي للتواجد في المنتدى في ورقة 13 استبدل الكود السابق بهذا Private Sub Worksheet_Calculate() Dim DataRange As Range Dim c As Range Dim count As Integer Dim o As Shape On Error GoTo errhandler For Each o In ActiveSheet.Shapes If o.Name Like "InvalidData_*" Then o.Delete Next Set DataRange = Cells.SpecialCells(xlCellTypeAllValidation) count = 0 For Each c In DataRange If Not c.Validation.Value Then Set o = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) o.Fill.Visible = msoFalse o.Line.ForeColor.SchemeColor = 3 o.Line.Weight = 4 count = count + 1 o.Name = "InvalidData_" & count End If Next Exit Sub errhandler: End Sub

السلام عليكم تم اضافة كود في زر الطباعة ليتم وضع تاريخ الطباعة مع * مع كلمة مدفوع في خانة الطباعة المقابلة لرقم الايصال كما سيتم ازالة زر الطباعة من الفورم المطبوع جرب المرفق الحركة.rar

السلام عليكم كون الملف يحمل اسمك فقد تم فك الحماية واليك الملفين بعد ازالة الحماية اضغط هنا

تفضل الملف الذي قمت بنقل الملف اليه وقد جعلته في شيتين ورقة 2 وورقة 3 تجربة1.rar

بصراحة انا جربيت الكود على ورقة جديدة وعمل بكل سلاسة والله اعلم

السلام عليكم نرجو وضع ملف لمتابعة عمل الكود

على ماذا يعتمد جلب البيانات الى الفورم هل على اسم السائق ام رقم الايصال

دالة مميزة وقوية بارك الله فيك استاذ عبدالله

السلام عليكم استبدل كودك السابق Private Sub Worksheet_Activate() UFormChang.Show End Sub بهذا Private Sub Worksheet_Activate() On Error GoTo 1 With UFormChang .kh_SetAddrss "الرئيسية", "a4:o4" .Show End With 1: If Err Then MsgBox "تاكد من صحة ادخال المتغيرات الاساسية في : " & vbCr & vbCr & "kh_SetAddrss", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "استخدام خاطىء" On Error GoTo 0 End Sub

يمكن تم اخفائها اي الاوفيس تستخدم 2007 ام 2003

هل الربط بين شيتتين في ملف واحد ام بين ملفين مختلفين

السلام عليكم اخي الكريم خطاك انك تكتب { قبل المعادلة وبعدها ويفترض ان تكون المعادلة =SUM(IF(K10:K17="غ";1;0)) ثم تضغط Ctrl + Shift+ Enter

أخي يوسف هل يتغير بالفورمات

للرفع

السلام عليكم اخي يوسف جرب هذا الكود قبل الفورمات فان كان الرقم لا يتغير امكننا التحكم في فتح الملف على كمبيوتر محدد Sub Abu_Ahmed() MsgBox CreateObject("Scripting.FileSystemObject").GetDrive("c:\").serialnumber End Sub

كود التفعيل سيكون فريد ولا يتكرر لجهازي حاسب وكود تفعيل جهازك هو في الجزء الاول الرقم صفر وليس حرف O 0VMA JRKD 6JKJ LFQP

إستخراج كود التفعيل يتم عن طريق برنامج به أكواد تستخرج هذه الارقام العلاقة بالرقم الموجود هو ان هذا الرقم الذي ظهر امامك لا يتكرر مرتين لاي جهاز فيقوم الكود في البرنامج بطريقة حساب معينة بإستبدال هذه الارقام برموز من 16 مقطع