مختار حسين محمود

السلام عليكم ورحمة الله وبركاته كنت منذ فترة قدمت لحضراتكم موضوعا بعنوان : إغلاق آلى لملف اكسل إذا ترك بدون استخدام على الرابط التالى : http://www.officena.net/ib/index.php?showtopic=59908 واليوم أعرض على حضراتكم موضوعا شبيها كما يبدو من عنوان الموضوع : كيفية تشغيل كود ( أى كود ) إذا ترك ملف الاكسل بدون استخدام الطريقة : 1- ضع الكود التالى فى حدث الملف Private Sub Workbook_SheetActivate(ByVal Sh As Object) ResetTime ' كود اعادة المدة كلما حدث تنشيط شيت End Sub Private Sub Workbook_SheetCalculate(ByVal Sh As Object) ResetTime ' كود اعادة المدة كلما حدث تغيير فى البيانات End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) ResetTime ' كود اعادة المدة كلما حدث تغيير فى شيت End Sub ضع الكود التالى بمديول عادى Public MyTime As Date Sub Auto_Open() MyTime = Now + TimeSerial(0, 0, 30) ' بداية عمل الكود بعد فتح الملف Application.OnTime MyTime, "MyMacro" End Sub Sub CancelOnTime() Application.OnTime MyTime, "MyMacro", , False End Sub Sub ResetTime() On Error Resume Next Application.OnTime EarliestTime:=MyTime, Procedure:="MyMacro", Schedule:=False MyTime = Now + TimeSerial(0, 1, 0) ' المدة الزمنية التى يعمل بعدها كودك Application.OnTime EarliestTime:=MyTime, Procedure:="MyMacro" On Error GoTo 0 End Sub Sub MyMacro() ' ضع كودك الذى تريد تشغيله اذا لم يكن الملف نشطا ' مثال Shell "C:\WINDOWS\system32\Bubbles.scr /S", vbMaximizedFocus ' انه كودك بالأمر التالى ResetTime End Sub 3 - احفظ الملف و أعد فتحه طالما أنت شغال على الملف لن يعمل الكود اذا توقفت عن العمل ستبدأ الفترة الومنية التى يعمل بعدها كودك تحياتى لكم وأتمنى أن ينال الملف اعجابك المرفق : تشغيل آلى لكود إذا ترك الاكسل بدون استخدام.rar

جزاك الله خيرا

الله الله عليك ربنا يعزك يا أستاااااااااااااااااااااااذى الغااااااااااااااااااااااااالى بس ازاى مشفتش الملف ده قبل كده ؟! أكيد كنت بآخد غطس تقبل منى وافر الاحترام والتقدير لشخصكم الكريم

السلام عليكم ورحمة الله وبركاته أخى أحمد الفلاحجى جزاك الله خيرا أخى و أستاذى الفاضل ياسر خليل جزاك الله خيرا وبعد اذن حضرتك أخى محمد الزريعى تفضل تم عمل المطلوب فى المرفق التالى بعد فك الضغط عن المرفق ستجد ملف + مجلد به ملفات 1 و 2 و 3 الخ كل واحد خاص بموظف ضع هذا المجلد فى البارتش d كما طلبت فى مشاركتك افتح الملف و شغل الكود و كرر التجربة مع تعديل بيانات الموظف ستجد ما تنشده بإذن الله أى استفسار سيكون معك أخوك مختار و أستاذنا ياسر خليل الفارس المغوار تحياتى loop through Excel files in a specified folder and perform a set task on them Mokhtar.rar

وعليكم السلام ورحمة الله و بركاته أستاذى الفاضل محمد أشكرك من كل قلبى على دعمك وتشجيعك لى كما أشكرك على مرورك الرائع جزاكم الله خيرا ..

=IF(H2="";"";IF(H2<>"000-000-0943";"لا";"نعم")) بعد اذن الأستاذين الفاضيلين جرب المعادلة السابقة ولا تحب نعملها بكود فى حدث الشيت ؟

أستاذى الغالى ياسر خليل بارك الله فيك و جزاك كل خير ... شوفت الغطس بيعمل ايه يا أحلى مستر أحاول أن أقدم لكم شيئا و لو ضئيلا مما تقدمه لاخوانك أستاذنا الغالى أخى الغالى ياسر العربى أولا مبروووووووووووك على انضمامك لفريق الموقع ومشكور على مرورك الجميل

السلام عليكم و رحمة الله شخصيا حاولت مرارا فى هذا الموضوع لم أصل الى شىء كلمة السر و اسم المستخدم كلمات حساسة لابد من ادخالها يدويا فى السواد الأعظم من المواقع الكود التالى يعطى الصفحة الرئيسية للمنتدى تماما مثل مرفق أخى الغالى عبدالعزيز البسكرى Sub Openofficena() Dim Website As String Website = "http://www.officena.net/ib/?_fromLogin=1&_fromLogout=1" ActiveWorkbook.FollowHyperlink Address:=Website, NewWindow:=True End Sub تحياتى

أستاذ نايف جرب التحميل مرة أخرى عذرا فقد حدث خطأ أثناء اضافة الموضوع

السلام عليكم و رحمة الله و بركاته اخوانى و أحبابى فى أوفيسنا اليوم باذن الله تعالى أعرض عليكم تعليمة برمجية صغيرة من سطر واحد تمكنك هذه التعليمة من الضغط على أى شكل تلقائى بمعلومية اسمه . مثال : اذا كان لديك شكلا تلقائيا اسمه Picture 1 كيف تضغط عليه برمجيا لا يدويا يمكن تنفيذ ذلك من خلال هذه التعليمة : Sub clickonashape() Application.Run ActiveSheet.Shapes("Picture 1").OnAction End Sub ممارسة الضغط على الشكل Picture 1 لن تشعر به الا اذا ربطت هذا الشكل بكود معين يؤكد لك أنه تم ضغطه لنربط الشكل بالكود التالى مثلا : Sub xxx() MsgBox "Hi Officna" End Sub جرب تشغيل الكود الأول ستجد أن الكود الثانى اشتغل و ظهرت الرسالة ( Hi Officna ) تطبيق على الكود السابق : اضافة شكل تلقائى لتشغيل كود مباشرة دون ربطه يدويا فى الكود التالى تم استثمار التعليمة السابقة و لكن بشكل مختلف : يتم اضافة شكل تلقائي فى مكان محدد بالشيت و له بعض الخصائص : من ضمن هذه الخصائص : أن يكون الشكل مربوطا بكود موجود مسبقا Sub addshpjoinedwithcode() Dim shp As Shape ' اضافة الشكل فى المكان المحدد Set shp = ActiveSheet.Shapes.AddShape(msoShapeSmileyFace, Left:=ThisWorkbook.Application.Range("E5").Left + 10, Top:=ThisWorkbook.Application.Range("E5").Top + 2, Width:=100, Height:=100) ' اضافة بعض الخصائص للشكل المضاف With shp .Name = "SmileyFace" .Fill.ForeColor.RGB = RGB(255, 192, 0) ' لون الشكل .Line.ForeColor.RGB = RGB(0, 176, 240) ' لون الخط .Adjustments.Item(1) = -2 ' الشكل يبدو عابسا .OnAction = "xxx" ' السطر الرئيسى : فى حالة ضغط الشكل يعمل الكود المحدد End With End Sub يعنى باختصار يلا يظهر الشكل تقدر تدوس عليه ليعمل الكود التالى : xxx Sub xxx() Application.ScreenUpdating = False With ActiveSheet.Shapes("SmileyFace") .Fill.ForeColor.RGB = RGB(146, 208, 80) ' لون الشكل الجديد .Line.ForeColor.RGB = RGB(192, 0, 0) ' لون الخط الجديد .Adjustments.Item(1) = 1 ' الشكل يبدو ضاحكا End With Application.ScreenUpdating = True MsgBox "Hi Officna" End Sub المرفقات : programmatically add shape , join it with specific code.rar programmatically click on a shape.rar أتمنى أن يكون الموضوع خفيفا و مفيدا لكم فى أكوادكم و برامجكم و السلام عليكم ورحمة الله وبركاته

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

[C16:F16].Resize(PCount).Value = Application.Transpose(P) بارك الله فيك أستاذى الغالى ياسر و جزيت خيرا بلا شك الكود رائع و سريع حتى مع وجود التسميات التى كنت أظن أنها تساهم فى بطء الكود الذى تفضل به أستاذنا الرائع الخلوق بن عليه لكن جربت الأرقام 1و2 و 3 و4 فى الأربع صفوف وبحث عن الرقم 10 و الكود توقف فى هذا السطر تحديدا رقم الخطأ 1004

السلام عليكم أستاذى بن عليه أثناء تجربتى لمرفق حضرتك وجدت الآتى : اذا وضعت مكونات العدد 100 ( 15 و 5 و 50 و 30 ) مثلا فى ال 4 صفوف و حذفت الكلمات الصف أ و الصف ب ...... الخ التى بأول كل صف فان الكود لا يعطى شيئا هذا دفعنى للعمل على الكود و تعديله بالكيفية الآتيه : الاستغناء عن كل التسميات فى المرفق والتى تزيد من بطء الكود و التعويض عنها بنطاقات فى الكود نفسه وهذا من شأنه اعطاء الكود مرونة وسرعة . الى جانب تعديلات أخرى بسيطة فى موضع ظهور النتائج Sub TEST2() ' Find every combination H.ben & Mokhtar 5/1/2015 Dim i As Integer Dim Adrs1 As String, Adrs2 As String, Adrs3 As String, Adrs4 As String Dim C1 As Range, C2 As Range, C3 As Range, C4 As Range, MyCel As Range Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range i = 16 Set MyCel = Sheets("Sheet1").Range("E12") Set Rng1 = Sheets("Sheet1").Range(Range("B3"), Cells(3, Cells(3, Columns.Count).End(xlToLeft).Column)) Set Rng2 = Sheets("Sheet1").Range(Range("B5"), Cells(5, Cells(5, Columns.Count).End(xlToLeft).Column)) Set Rng3 = Sheets("Sheet1").Range(Range("B7"), Cells(7, Cells(7, Columns.Count).End(xlToLeft).Column)) Set Rng4 = Sheets("Sheet1").Range(Range("B9"), Cells(9, Cells(9, Columns.Count).End(xlToLeft).Column)) On Error Resume Next With Application .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual End With Sheets("Sheet1").Range(Cells(16, 2), Cells(Rows.Count, 6)).ClearContents For Each C1 In Rng1 Adrs1 = C1.Address For Each C2 In Rng2 Adrs2 = C2.Address For Each C3 In Rng3 Adrs3 = C3.Address For Each C4 In Rng4 Adrs4 = C4.Address If C1 + C2 + C3 + C4 = MyCel Then Cells(i, 2) = i - 15 Cells(i, 3) = Adrs1 Cells(i, 4) = Adrs2 Cells(i, 5) = Adrs3 Cells(i, 6) = Adrs4 i = i + 1 End If Next Next Next Next On Error GoTo 0 Set MyCel = Nothing Set Rng1 = Nothing Set Rng2 = Nothing Set Rng3 = Nothing Set Rng4 = Nothing With Application .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic End With End Sub تحياتى لك من قلبى سيدى الفاضل الخلوق . و السلام عليكم Find every combination H.ben & Mokhtar.rar

السلام عليكم أستاذى الفاضل بن عليه كل عام و أنت أقرب الى الله رغم بط ء الكود ( بسبب الحلقات التكرارية ) الا انه كود ذكى بجد وفعال فى آداء وظيفته أشكرك بجد على هذه الهدية الثمينة . أخوك و تلميذك مختار

Sub MokhtarSquare2() Application.ScreenUpdating = False With Cells .RowHeight = 6.694 .ColumnWidth = 1 End With Application.ScreenUpdating = True End Sub جعل عرض كل الأعمدة = 2.17 و ارتفاع كل الصفوف = 18 هذه الأرقام تجعل كل خلايا الشيت تبدو مربعة الشكل بنسبة كبيرة جدا وهو ما تريده و تقريبا تقدر تقول كل 1 نقطة فى عرض العمود = 5.694 فى ارتفاع الصف جرب الكود السابق ستجد أن كل خلايا الشيت مربعة الشكل زود الزوم ستجد أيضا الخلايا مربعة الشكل و الله أعلى وأعلم

بالشكل ده Private Sub TextBox1_Change() If Me.TextBox1.Text = "سبحان الله" Then Command1.Enabled = True End Sub

جرب الكود Sub MokhtarSquare() Cells.RowHeight = 18 Cells.ColumnWidth = 2.71 End Sub

الكود يسرى على الأرقام تعم و لكن بطريقتى تحديد الخلايا التى تحتوى على حرف أو رقم محدد.rar و ليس بنفس الكيفية التى تطلبها لأن ذلك يتطلب عمليات حسابية وهذا لا يتوفر فى الكود تحياتى

رائع رائع رائع يا فخر المنتدى و أستاذنا الغالى وممكن يكون الكود بالشكل ده : Sub ReverseRows2() Dim i As Long, j As Long j = Range("D4").CurrentRegion.Columns.Count + 1 ' عدد الأعمدة المتاحة For i = 4 To j ' من العمود الرابع الى عدد الأعمدة Cells(5, i).Value = Cells(4, j).Value j = j - 1 Next i End Sub

الأب الفاضل و أستاذنا الكبير محمد حسن السلام عليكم تقبل الله دعائك و رحم من أسماك محمداً اللهم آمين آمين آمين أشكرك شكرا جزيلا على هذه الكلمات الغالية و التى أعتبرها وساما على صدرى أحبك فى الله و لك منى كل التحية و التقدير و الاعزاز لشخصكم الكريم

السلام عليكم ورحمة الله وبركاته أخى العزيز أبى الحسن و الحسين أشكرك و جزاكم الله خيرا شرُفت بمرورك أخى العزيز ابراهيم أبو ليله أشكرك شكرا جزيلا على هذه الثقة الغالية و أحمد الله عز و جل على توفيقه لى وعلى أنى حققت لكم قدرا ولو كان يسيرا من المتعة مع الاكسل جزاك الله خيرا و شرُفت بمرورك الكريم

السلام عليكم أبا راكان اضغط الرابط التالى تحياتى

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

السلام عليكم و رحمة الله و بركاته اليوم أقدم الى حضراتكم كودى الجديد الذى تستطيع من خلاله تطبيق التنسيق الشرطى داخل اليوزر فورم أو بعبارة أخرى نقل البيانات بالتنسيقات الشرطية من خلايا محددة الى كنترولات داخل اليوزر فورم مثل التكست بوكس وهذا تحقيقا لطلب أحد الزملاء و هو الأخ ابو راكان العودة على هذا الرابط : http://www.officena.net/ib/topic/65950-%D9%87%D9%84-%D9%8A%D9%85%D9%83%D9%86-%D8%A7%D8%B3%D8%AA%D8%AE%D8%AF%D8%A7%D9%85-%D8%A7%D9%84%D8%AA%D9%86%D8%B3%D9%8A%D9%82-%D8%A7%D9%84%D8%B4%D8%B1%D8%B7%D9%8A-%D9%81%D9%8A-%D8%A7%D9%84%D9%8A%D9%88%D8%B2%D8%B1-%D9%81%D9%88%D8%B1%D9%85/ الكود و عليه الشرح : Option Base 1 ' التصريح بأن القيمة الافتراضية الصغرى فى المصفوفة = 1 Private Sub UserForm_Activate() ' by Mokhtar 29/12/2015 ' وظيفة الكود ' تطبيق التنسيق الشرطى على كنترول داخل اليوزرفورم ' -------------------------------------------- ' التصريحات والمتغيرات Dim X As Integer Dim myArray As Variant myArray = Array("B2", "C2", "D2", "E2", "F2", "G2", "H2", "I2") ' مصادر التكست بوكس ' فى حالة حدوث خطأ ما تجاهله وانتقل الى الاجراء التالى On Error Resume Next ' حلقة تكرارية على التكست بوكس لتعبئته بالقيم والتنسيق الشرطى من المصادر ' ---------------------------------------------------------------------- For X = 1 To 8 ' عدد التكست بوكس With Me.Controls("Textbox" & X) ' لكل تكست بوكس فى الثمانية ' مصدر نص التكست بوكس .Text = Sheets("ورقة1").Range(myArray(X)).Value ' ' مصدر لون التكست بوكس .BackColor = Sheets("ورقة1").Range(myArray(X)).DisplayFormat.Interior.Color ' ' مصدر لون خط التكست بوكس .ForeColor = Sheets("ورقة1").Range(myArray(X)).DisplayFormat.Font.Color ' End With ' With انهاء جملة Next X ' انتقل الى التكست بوكس التالى ' فى حالة حدوث خطأ ما انتقل الى نقطة البداية On Error GoTo 0 End Sub المرفق : أتمنى أن يكون كودا سهلا و مفيدا لكم فى أعمالكم و برامجكم و أكوادكم بإذن الله تعالى و لا يفوتنى أن أوجه الشكر للأستاذ أبو راكان الذى أوحى لى بفكرة هذا الكود لا تنسونا بدعوة بظهر الغيب تحياتى لكم و كل عام و أنتم أقرب الى الله Conditional Formatting on Userform by Mokhtar.rar

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