نجوم المشاركات

السلام عليكم ورحمة الله وبركاته =============== Thermometer Chart ================= من خلال هذا الرسم البيانى يمكنك عرض المحقق من التارجيت او الهدف فى شكل ترموميتر . ملحوظه هذا الشكل يستخدم فى Dashborad وهو مشهورر وتم عرضها اليكم فى شكل خطوات مشروحة بالصور داخل ملف الاكسيل نفسه للاحتفاظ بها والتطبيق اتمنى ان تفيدكم وارجو منكم مشاركة الجميع (زكاة العلم نشره). thermometer.rar

لتفعيل النسخ الإحتياطي التلقائي ، قم بما يلي: أولاً : إعدادت إختيار قواعد البيانات لعمل النسخ الإحتياطى التلقائي لها 1) انقر على الزر "إعداد النسخ الإحتياطي التقائي". أدخل المسار الكامل لقواعد البيانات التي ترغب في النسخ الاحتياطي لها.بإستخدام الزر "استعراض لإختيار قواعد البيانات" 2)انقر على الزر "إضافة قاعدة بيانات إلي القائمة" لإضافة قاعدة بيانات جديدة. 3) انقر مرتين على أي قاعدة بيانات في القائمة للتعديل أو الحذف. ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ثانياً : إعدادات مسار تخزين النسخ الإحتياطى التلقائي حدد المسار الكامل الذي تريد حفظ قواعد بيانات النسخ الاحتياطي.فيه عن طريق النقر على الزر "تحديد مسار التخزين" وهذا المسار يجب بالفعل أن يكون موجوداً أو سوف يتم إحباط العملية. ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ثالثاً : إعدادات وقت النسخ الإحتياطي التلقائي تحديد وقت بدء النسخ الإحتياطي التلقائي هام جداً جداً جداً أدخل الوقت بهذا التنسيق (HH:MM:SS AM / PM) شرح التسيق HH الساعة MM الدقيقة SS الثانية AM / PM أو ص / م وهذا يشير لتحديد الساعة صباحا او مساءً ويظهر هذا التنسيق فقط عندما تكون إعدادت نظام التشغيل تم تحديد الوقت فيه على نظام 12 ساعة مثال عندما نريد نسخ تلقائى فى تمام الساعة الواحدة ظهراً تكون بهذا الشكل (01:00:00 م ) وفي حالة ضبط إعدادت الوقت فى نظام التشغيل 24 ساعة يكون التسيق (HH:MM:SS) مثال عندما نريد نسخ تلقائى فى تمام الساعة الواحدة ظهراً تكون بهذا الشكل (13:00:00) ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ملاحظـــــة هامــــــــة ـــــــــــــــــــــــــــــــــــ لكى يتم عمل النسخ التلقائي لقواعد البيانات بشكل تلقائي طبقاً للإعدادت المسبقة 1- يجب فتح النموذج المسئول عن النسخ الإحتياطي التلقائي من خلال النقر على الزر "بدء النسخ الاحتياطي التلقائي" وإلا لن يتم النسخ الاحتياطى تلقائيا فى الوقت المحدد طبقاً للإعدادت المحددة 2- فى حالة إستخدام شاشة التوقف أو شاشة حماية إذا كنت ترغب فى الحصول على السرية والحماية للجهاز الخاص بك فى غيابك لن يؤثر ذلك على النسخ التلقائي ☺ ملاحظة هامة جدا جدا جدا يتم تحديد قاعدة بيانات أو أكثر لعمل نسخ احتياطى لها وضغط واصلاح مرة واحدة فقط من الاعدادت يتم تحديد المسار المراد حفظ النسخ الاحتياطى مرة واحدة فقط وقمت بعمل طريقة تجعل البرنامج يقوم كل يوم بعمل مجلد باسم وتاريخ اليوم دون اى تدخل من المستخدم فقط غير فتح النموذج "frmTimer" مشكلة لو تم وضع باسورد لحماية قاعدة البيانات المراد عمل نسخ احتياطى لها عند فتحها فلن يكتمل النسخ التلقائى الالى بسبب كلمة السر هذه ولن يتم عمل اى نسخ احتياطى لباقى قواعد البيانات الاخرى للامانة العلمية : هذا البرنامج حصلت عليه من احد المنتديات الاجنبية ولكن قمت بتعديلات كثيرة جدا للوصول الى هذه النتيجة المثمرة ان شاء الله واضعها بين أيديكم حتى تعم الفائدة AutoBackup.rar

بسم الله و ما شاء الله اللَّهُمَّ انْفَعْنَا بِمَا عَلَّمْتَنَا , وَعَلِّمْنَا مَا يَنْفَعُنَا , وَزِدْنَا عِلْمًا إِلَى عِلْمِنَا اهداء لكل من شارك بعلمه اقل ما يقال لكم "عندما تنتهى كلمات الابداع و تبدأ من جديد و تنتهى عندكم" بارك الله لكم ( فكرة المدونة هى سهولة الوصول و البحث فى المنتدى ) للذهاب الى ملف _ المدونه الاصدار الاول من هنا مدونة اعمال ايقونات الماس لمنتدى اوفيسنا_سلسله تجميعيه 13_الرابط المباشر ملفات و صفحات اعضاء منتدى اوفيسنا أعمال العلامه القدير الراحل عماد الدين الحسامى مواضيعى فى منتدى اوفيسنا _رابط صفحة أ / عبدالله باقشير مواضيعى فى منتدى اوفيسنا _رابط صفحة أ / ضاحي الغريب بوابة نور التعليمية _رابط صفحة أ / ضاحي الغريب فهرس موضوعات العبد الفقير إلى الله _رابط صفحة أ / ياسر خليل أبو البراء قناتي على اليوتيوب Youtube _رابط صفحة أ / ياسر خليل أبو البراء YasserKhalil Excel Lover _رابط صفحة أ / ياسر خليل أبو البراء مصطبة الحبايب _رابط صفحة أ /ياسر العربى .Excel4us _رابط صفحة أ / يحيى حسين مواضيعى بالمنتدى _ أ / شوقى ربيع مدونتى على الوورد بريس _ رابط صفحة أ / A L M A I S T R O مواضيعي بالمنتدي All My Work Here _ رابط صفحة أ / عادل حنفي صفحتي الشخصية في أوفيسنا _ رابط صفحة أ / محمد صالح ** برامج مصممه على الأكسيل * * _ رابط صفحة أ / حسام نور اتعلم اون لاين _ رابط صفحة أ / معتصم محمد اتعلم اون لاين_ facebook _ رابط صفحة أ / معتصم محمد اتعلم اون لاين_ Youtube _ رابط صفحة أ / معتصم محمد اتعلم ماكرو سوفت اكسيل _ رابط صفحة أ / معتصم محمد قناتى على يوتيوب _ رابط صفحة أ / عبد الفتاح كيرة مدونتى _ رابط صفحة أ / عبد الفتاح كيرة

اخى الكريم يرجى متابعة الخطوات بحرص من الصور المرفقه فانا لدى اوفيس 2003 وشغاله كويس معايا شغاله علي جهاز لاب توب وجهاز كمبيوتر اخر ومافيهمش مشكله الاعدادات المرفقه خاصه بالجهاز بتاعى هى مكتوبه فى المانيوال بتاعه بنفس الارقام وطبعا دى مش ثابته لكل الاجهزه عموما لكى تتاكد ان الاداه شغاله قم بعمل اتصال هايبر تيرمنال جديد فاذا مرت الشاحنه وتم قياس الوزن المفروض هاتظر الرقم علي شاشة الكمبيوتر فى الهايبرتيرمنال ولو ماشتغلش يبقى ممكن يكون كابل السيريالىبورت عاوز تعديل بس للاسف انا مش ضليع قوى في تعديل الكابل لانه بيقطعه من الطرفين وبيبدل سلكين منهم تقريبا 2 مع 3 و3 مع 2 لان الجهاز اللي عندى بيشتغل بسلك زى بتوع الطابعات يو اس بي مش سيريال بورت كابل ممكن تدخل علي النت وتشوف موضوع الكابل ده يتحل ازاى

السلام عليكم ورحمة الله وبركاتة موضوعنا اليوم اردت ان تكون صيغتة صيغة عامة تخدم الكثير من موضوعات جداول البيانات وهو ادراج مجموع كل صفحة وايضا المجموع الكلي وكنت قد قدمت هذا الموضوع منذ سنوات وقد اعادت هذة الذكري الي ذهني احدي المشاركات منذ ايام قليلة فبحثت عن الموضوع ولكني لم اجده ثم بحثت في المنتديات الاجنبية لعلي اجد كود لهذا الموضوع فلم اجد الا كود واحد فقط يغطى هذا الموضوع وهو للمبرمج Ole P. Erlandsen منذ عام 1999 وهو كود وحيد لا يوجود غيره في اي منتدي عربي او اجنبي حاولت تطويعة ( من باب الاستسهال بدلا من كتابة كود جديد ) ولكن صعب عليا تطويعه فتركت الموضوع ثم امس ومضت لي فكرة بناء كود جديد فتوكلت علي الله وكانت هذه النتيجة الكود له 3 مدخلات يجب ضبطها وهي اول 3 سطور في الكود '========================================= First_Cel = "A1" ' عنوان اول خلية في جدول البيانات Count_Row_In_Page = 10 ' عدد الصفوف في كل صفحة Col_Total = "E" ' عمود المجموع '========================================= انظر المرفقات الكود Option Base 1 Sub Subtotals_For_Each_Page() ' '======================================================================= First_Cel = "A1" ' عنوان اول خلية في جدول البيانات Count_Row_In_Page = 10 ' عدد الصفوف في كل صفحة Col_Total = "E" ' عمود المجموع '========================================= Ttitle_1 = "اجمالـــي صفحـــة" Ttitle_2 = "اجمالـــي الصفحـــات :" '======================================================================= ScreenOff Dim Sh_Total_Page As Worksheet Dim Rng As Range Dim Arr() Dim Arr_Page() '======================================================================= ActiveSheet.ResetAllPageBreaks Maximum_Row = ActiveSheet.HPageBreaks(1).Location.Row - 3 If Count_Row_In_Page < 1 Or Count_Row_In_Page > Maximum_Row Then MsgBox "عدد الصفوف لكل صفحة من 1 الي " & Maximum_Row: Exit Sub '======================================================================= Set Sh_Total_Page = Sheets("مجموع_الصفحات") First_Col = Range(First_Cel).Column Count_Col = Cells(Range(First_Cel).Row, Columns.Count).End(xlToLeft).Column End_Row = Cells(Rows.Count, First_Col).End(xlUp).Row Set Rng = Range(First_Cel).Offset(1) Set Rng = Range(Rng, Cells(End_Row, Count_Col)) Arr = Rng '======================================================================= With Sh_Total_Page .Cells.Delete Shift:=xlUp Range(Range(First_Cel), Cells(Range(First_Cel).Column, Count_Col)).EntireColumn.Copy .Range("A1").Insert Shift:=xlToRight .Rows(Range(First_Cel).Offset(1).Row & ":" & Rows.Count).ClearContents End With '======================================================================= Page_Counter = 1 Grand_Total = 0 Col_Total = Columns(Col_Total).Column For x = LBound(Arr) To UBound(Arr) Step Count_Row_In_Page ReDim Arr_Page(Count_Row_In_Page + 1, Count_Col) Row_Offset = x Total_Page = 0 For Row = 1 To Count_Row_In_Page Col_Counter = 0 Total_Page = Total_Page + Arr(Row_Offset, Col_Total) For Col = 1 To Count_Col Col_Counter = Col_Counter + 1 Arr_Page(Row, Col_Counter) = Arr(Row_Offset, Col_Counter) Next Row_Offset = Row_Offset + 1 On Error Resume Next Next Grand_Total = Grand_Total + Total_Page '======================================================================= Arr_Page(Count_Row_In_Page + 1, 1) = Ttitle_1 & Page_Counter & " : " Arr_Page(Count_Row_In_Page + 1, Col_Counter) = Total_Page Page_Counter = Page_Counter + 1 '======================================================================= With Sh_Total_Page End_Row = .Cells(Rows.Count, "A").End(xlUp).Row + 1 Set Rng = .Cells(End_Row, "A") Set Rng = Rng.Resize(Count_Row_In_Page + 1, Col_Total) Rng = Arr_Page End_Row = .Cells(Rows.Count, "A").End(xlUp).Row + 1 Range(.Cells(End_Row - 1, 1), .Cells(End_Row - 1, Count_Col)).Font.Bold = True Range(.Cells(End_Row - 1, 1), .Cells(End_Row - 1, Count_Col)).Font.ColorIndex = 5 End With Erase Arr_Page Next With Sh_Total_Page End_Row = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(End_Row, "A") = Ttitle_2 .Cells(End_Row, Col_Total) = Grand_Total Range(.Cells(End_Row - 1, 1), .Cells(End_Row, Count_Col)).Font.Bold = True Range(.Cells(End_Row - 1, 1), .Cells(End_Row, Count_Col)).Font.ColorIndex = 5 Range(.Cells(End_Row, 1), .Cells(End_Row, Count_Col)).Font.ColorIndex = 3 .Select End With '======================================================================= Every_Row = Count_Row_In_Page + 1 With ActiveSheet .ResetAllPageBreaks TotalPageBreaks = ActiveSheet.HPageBreaks.Count Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row For Row_Index = Every_Row + 2 To Lastrow Step Every_Row If Row_Index = Lastrow Then .HPageBreaks.Add Before:=.Cells(Row_Index + 1, 1) Else .HPageBreaks.Add Before:=.Cells(Row_Index, 1) End If Next End With TotalPageBreaks = ActiveSheet.HPageBreaks.Count ActiveSheet.HPageBreaks(TotalPageBreaks).Delete '======================================================================= End_Row = Cells(Rows.Count, "A").End(xlUp).Row Set Rng = Range(Range(First_Cel), Cells(End_Row, "A")) Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete With Sh_Total_Page.PageSetup .PrintTitleRows = "$1:$1" End With End_Row = Cells(Rows.Count, "A").End(xlUp).Row + 1 Rows(End_Row & ":" & Rows.Count).Delete Shift:=xlUp On Error GoTo 0 '======================================================================= ScreenOn ' End Sub المرفقات ادراج مجموع كل صفحة & المجموع الكلي.rar

تحياتى استاذنا الفاضل و جزاك الله خيرا

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

السلام عليكم إخواني الكرام أقدم لكم اليوم ملف قمت بإعداده ، لنتعلم من خلاله كيفية عمل قائمة منسدلة يمكن البحث من خلالها ... الملف به كل التفاصيل أرجو أن ينال إعجابكم وأن ينفعكم به Searchable Drop Down List.rar

وانت بصحة وسلامة أخي الغالي محمد

وعليكم السلام أخي الكريم طاهر جرب الكود التالي عله يفي بالغرض إن شاء الله Sub Test() Dim I As Long, Sh As Worksheet Application.ScreenUpdating = False For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> "أستدعاء البيانات" Then For I = 1 To Sh.Cells(Rows.Count, 1).End(xlUp).Row If Sh.Cells(I, 1).Font.Color <> 255 Then With Sheets("أستدعاء البيانات") .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(1, 5).Value = Sh.Cells(I, 1).Resize(1, 5).Value End With End If Next I End If Next Sh Application.ScreenUpdating = True End Sub تقبل تحياتي

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

لدينا مجموعة من الأسماء المكررة في جدول امام كل اسم المبلغ المستحق عليه كيف نقوم بترتيب هذه الاسماء دون تكرار ابتداءً من الاسم الذي عليه اكبر مبلغ مع ادراج مجموع ما يستحق على كل اسم انظر الى المرفق Rank_By_Sum.rar

صديقي العزيز شكرا على الاجابه أظنك نسيت ان تقوم بارفاق الملف لا يوجد ملف مرفق

الملف المرفق بيه طريقتان .. الاولى .. تنفيد الكود واظهار النتائج عند التغيير علي الخلايا في الاعمدة A>>G الثانية .. تنفيذ الكود من الزر اختر احدى الطريقتين ..مع العلم اني طبقت علي العمود L فقط .. وطبق الخطوات علي العمودين الاخرين M-N

تفضل 404.Sales (AccessFIX).accdb.zip

جعفر

استخراج حالة الطالب ناجح ودور تان .. بطريقة اقطاب المنتدى شاء الله تعالى ان يجتمع عملان لافذاذ المنتدى وهما العالم العلامه والبحر الفهامه عبد الله باقشير ومعه العبقري ذو الخلق الحسن ياسر العربي - جزاهم الله كل خير - في كود لكل منهما يستطيع كود كل واحد منهم ان يستخرج الطلاب الناجحين وطلاب الدور التاني بسلاسه اولا : هذا كود العلامه عبد الله باقشير حفظه الله .. بشرح اسطر الكود Option Explicit ''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير ''الهدف من الكود ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''وقد تمت اضافة جزئيه حسب المتطلبات الجديده للمدارس ''بفضل الله اولا ثم العبقري ياسر العربي ' اسماء المواد Const nTEST As String = "عربي" & "," & _ "رياضيات" & "," & _ "دراسات" & "," & _ "انجليزى" & "," & _ "علوم" & "," & _ "مجموع" & "," & _ "رسم" & "," & _ "العاب" & "," & _ "نشاط1" & "," & _ "نشاط 2" & "," & _ "دين" '-------------------------------------- ' ارقام اعمدة الدرجة الاصلية ' بالتسلسل حسب اسماء الموادوعددها Const ColmnTotal As String = "13,22,31,40,51,57,54,59,64,69,82" ' ارقام اعمدة الفصل الثاني 'ويجب ان يتساوى عددها 'مع عدد اسماء المواد 'لعليا التي كتبت ' وهنا المجموع ً Const ColmnTest2 As String = "9,18,27,36,47,54,57,62,67,72,78" ' رقم صف النهاية الصغرى Const iRs As Integer = 6 ' اول صف للبيانات Const TopRow As Integer = 7 Sub kh_Tgrba() Dim sCont As Integer, R As Integer Dim Tst As String Dim xx As String Dim xxx As String Dim go As String Dim Arr, i, x On Error GoTo 0 '------------------ ' عدد الطلبة ' ممكن يؤخذ من خلية او يكتب كتابة sCont = Sheets("بيانات المدرسة").Range("B10").Value '--------------------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------ sCont = sCont + TopRow With ActiveSheet For R = TopRow To sCont If Not IsEmpty(.Cells(R, "C")) Then Tst = kh_Test(R) '''الاضافه هنا '--متغير اســم ورقم العمود '_ما تم التعديل عليه هذه الجزئية تم اضافة عليها بعض الاسطر Select Case .Cells(R, 112) 'لتحديد النوع للطالب Case 1: xx = "له دور ثان في": xxx = "ناجح": go = "ومنقول " & Sheets("بيانات المدرسة").Range("b16") Case 2: xx = "لها دور ثان في": xxx = "ناجحه": go = "ومنقوله " & Sheets("بيانات المدرسة").Range("b16") End Select If Len(Tst) Then .Cells(R, "CW") = xx Else .Cells(R, 101) = xxx '--متغير اسم العمود 'عمود ملاحظات المواد .Cells(R, "CX") = kh_Test(R) '--متغير رقم العمود 'عمود رقم النتيجة Select Case .Cells(R, 101) '--متغير اسم العمود 'اذا كان الطالب ناجح او ناجحةاذن يتم اعتماده منقول او منقوله للصف التالي Case xxx: .Cells(R, "CX") = go End Select x = 0 ''مصفوفة باسماء خلاياالمواد ''متغير أسماء اعمدة اختبار الترم التاني Arr = Array(.Range("i" & R), .Range("r" & R), .Range("aa" & R), .Range("aj" & R), .Range("at" & R), .Range("au" & R), .Range("bb" & R), .Range("bg" & R), .Range("bl" & R), .Range("bq" & R), .Range("bz" & R)) ' حلقة تكرارية للبحث داخل المصفوقة عن الغائب اذا وجد يتم اضافته للمتغير اكس For Each i In Arr Select Case i Case "غ": x = x + 1 End Select Next 'اذا كان المتغير اكس يساوي عدد جميع مواد الترم الثاني اذن هو غائب Select Case x Case 11: .Cells(R, "CX") = "غياب" End Select 'الشرط الثاني اذا كان المجموع يساوي صفر اذن غائب Select Case .Cells(R, 52) Case 0: .Cells(R, "CX") = "غياب" End Select 'اذا كان الطالب باق بشرط ان كون في الصف الاول او الثاني يصبح ناجح بحكم القانون If .Cells(R, 111) = "باق" And (Sheets("بيانات المدرسة").Range("b12") = 1 Or Sheets("بيانات المدرسة").Range("b12") = 2) Then: .Cells(R, "CX") = go & " بحكم القانون": .Cells(R, "Cw") = xxx '____________________________________________ End If Next End With 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox "تم اظهار النتيجة بنجاح" End If End Sub Function kh_Test(iRow As Integer) As String Dim vT, sT Dim NN As String, TT As String Dim ctlt As Integer, ctst As Integer Dim c As Integer, CC As Integer Dim ib As Boolean CC = UBound(Split(nTEST, ",")) For c = 0 To CC ib = False NN = Split(nTEST, ",")(c) ctlt = Split(ColmnTotal, ",")(c) ctst = Split(ColmnTest2, ",")(c) vT = Cells(iRow, ctlt) If Not IsEmpty(vT) Then Select Case vT Case Is = "غ", "غـ": ib = True Case Is < Cells(iRs, ctlt): ib = True End Select End If If ctst = 0 Then GoTo 1 sT = Cells(iRow, ctst) If Not IsEmpty(sT) Then Select Case sT Case Is = "غ", "غـ" NN = NN & " لثلث الدرجة": ib = True Case Is < Cells(iRs, ctst) NN = NN & " لثلث الدرجة": ib = True End Select End If 1: If ib Then TT = TT & IIf(Len(TT), " - ", "") & NN Next kh_Test = TT End Function استخراج حاله الطالب للعلامه عبد الله باقشير.rar اولا : هذا كود العبقري ياسر العربي حفظه الله .. بشرح اسطر الكود Sub Yasser() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''شرح الكود '' 3 متغيرات Dim LR As Integer, _ LR1 As Integer, _ T As Integer ''صف البدايه T = 7 ''متغير اسم شيت الرصد With Sheets(1) ''موقع رقم الجلوس LR1 = .Cells(7, 2) '' متغير اسم شيت الجدول ' هنا يتم جلب اول رقم الجلوس الى شيت المعادلات للعمل عليه Sheet3.Range("c6") = LR1 'متغير لمعرفة اخر صف به بيانات LR = .Cells(.Rows.Count, 1).End(xlUp).Row ''المدى المطلوب مسحه لكتابة حاله الطالب فيه Range("cw7:cx" & LR).ClearContents 'حلقة تكرارية من اول طالب الى اخر طالب For R = 7 To LR 'اذا كانت قيمة حرف التيي اكبر من او يساوي اخر طالب يذهب خارج الحلقة التكرارية الى السطر صفر If T - 1 >= LR Then GoTo 0 Else 'ايقاف تحديث الشاشة Application.ScreenUpdating = False 'هنا يتم تطبيق كود اكس اكس الخاص بوضع الفواصل بين المواد xxx ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 101) = Sheet3.Cells(2, 9) ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 102) = Sheet3.Cells(2, 10) 'هنا قيمة الخلية المذكورة الخاصة برقم جلوس ' الطالب تساوي نفسها +1 للذهاب الى الطالب التالي لتطبيق الكود مره اخرى Sheet3.Range("c6").Value = Sheet3.Range("c6").Value + 1 'وهنا بالمثل نضيف واحد الى هذا المتغير للنزول الى الصف التالي وهكذا حتى تنتهي البيانات T = T + 1 End If Next End With '' متغير اسم شيت الجدول وموقع الخليه 0 Sheet3.Range("c6") = LR1 'اعادة تحديث الشاشة Application.ScreenUpdating = True MsgBox "تم بحمد الله" End Sub ''-------------------------------------------------------- Sub xxx() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 '' هذف الكود هو وضع شرطه بين مواد الدور التاني ''شرح الكود With Sheet3 Dim Rng As Range 'حلقة تكرارية لصف المواد التى لها دور ثان For Each Rng In .Range("d10:n10") 'اذا كانت الخلية بها بيانات اذن يتم تطبيق التالي If Rng <> "" Then 'ضع المادة بالخلية الموضحه .Range("j11") = .Range("j11") & Rng 'وضع الشرطة بعد كل مادة .Range("j11") = .Range("j11") & " -" End If Next Rng 'بعد الانتهاء من وضع كل الفواصل تظل شرطة اخيرة يتم حذفها بهذه الطريقة .Range("J12").FormulaR1C1 = "=LEFT(R[-1]C,LEN(R[-1]C)-1)" .Range("J12") = .Range("J12").Value .Range("j11").ClearContents End With End Sub حفظ الله كل من ساهم في اخراج هذا العمل المتميز استخراج حاله الطالب للعبقري ياسر العربي.rar

اخي الكريم ناصر مشكور على هذه اللفته الطيبة وما نحن الا طلاب بجانب عمالقة المنتدى الكرام مثل ا /عبد الله باقشير وما قمت بعمله هو تعديل بسيط بداخل الكود ليتوافق مع ما تم طلبه اما الكود الخاص بي فهو يعتمد اعتماد كلي على المعادلات بالشيت رقم 3 هو ممكن يكون بطئ بعض الشئ الا انه يتميز بالمرونة امام كل من يستخدم المعادلات ولا يعرف الكثير عن الVBA فقط يقوم بالتعديل على المعادلات كما يشاء فهي كلها عبارة عن دوال شرطية تعتمد على شرط او اكثر للحصول على النتيجة المرجوه والكود ما هو الا ناقل لنتائج المعادلات الى جانب كل طالب تقبل فائق احترامي وتقديري

اخي ابراهيم جزاكم الله خيرا على المرور و انا ايضا اشتقت للجميع ( إييييييييه أيام زمان لما كنا في الاعدادي ههههههههههههه ) اسأل الله ان يوفقكم و يسدد خطاكم بالمناسبة تقبل الله منا و منكم صالح الاعمال و عيدكم مبارك و كل عام و انتم و كل الاسرة بخير

جرب هذا الملف صفحة رقم 3 القوائم المنسدلة الخضراء مطاطة (بمعنى انها تستجيب لتغيير البيانات في الصفحة الرئيسية ولا تذكر المكرر الا مرة واحدة) TEST FILTERS salim 2.rar

السلام عليكم و رحمة الله و بركاته اليوم أقدم الى حضراتكم كودى الجديد الذى تستطيع من خلاله تطبيق التنسيق الشرطى داخل اليوزر فورم أو بعبارة أخرى نقل البيانات بالتنسيقات الشرطية من خلايا محددة الى كنترولات داخل اليوزر فورم مثل التكست بوكس وهذا تحقيقا لطلب أحد الزملاء و هو الأخ ابو راكان العودة على هذا الرابط : 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

الاخ الفاضل ياسر خليل أبو البراء كرما ماهي الطريقة المثالية لادخال الصورة في الخلية كما في مثالك زائدا ادخال الاسم في الخلية المجاورة زادك الله علما وفضلا وجزاك الله خير

السلام عليكم ورحمه الله وبركاته مواقع اعجبتني حبيت اشاركم اياها https://exceljet.net/formulas http://www.mrexcel.com/forum/

الله يرحم والديك ويسكنهم فسيح جناته

زاد الله فضلك أخي محمد انا قلت: وكنت اعني هذا الجدول: بحيث case1 يكون له الاولولوية في الفرز ، ثم يليه case2 ، فالرجاء تكملة الجدول بجميع المعايير ، ثم ننظر طريقة التعامل مع البرنامج والنموذج والكمبوبوكس القصد هنا ، انك تعطينا كل المطلوب ، ثم نحاول نحن ترجمة طلبك الى برنامج الله يجزيك كل خير ان شاء الله أخي أبوعبدالله ، يعني بعدك مصدقك ان كل العمانية سِحّار جعفر

ربما يكون المطلوب تم نغيير اسماء الصفحات الى الاجنبية لسهولة التعامل مع المعادلات معادلة واحدة تكتب في الخلية A6 وتسحب يساراً (تم حماية الخلايا التي تحتوي على معادلات لعدم العبث بها عن طريق الخطأ) ديناميكي مع زيادة عدد الصفحات والبيانات (شرط تسمية الصفحة حسب الاسم month والبيانات تكون في نفس الخلايا) جدول مرتبات salimالموظف.rar

1 - تم التعديل على آلية ادخال البيانات بالفورم بما يسمح بادخال المعاير فقط المرة تلو الأخرى بعد ادخال الصنف للمرة الأولى فقط 2 - جرب أن تختار المعيار الجديد "Mixed" ووافنا بالنتائج. ملاحظة: اغسل يديك من هذه الفكرة بعدما يرد أستاذنا جعفر - صاحب السبق والفضل - فأنا بانتظار أحدى مفاجآته السحرية التى طالما يبهرنا بها Hlawany(Parameter) 2003.rar

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

السلام عليكم ورحمة الله وبركاته اليك الحل جدول مرتبات الموظف.rar

تفضل Port_Com_Test.rar

اخي الموضوع عبارة عن 2 userform userform رئيسئ والثاني فرعي انت لما تروح edit انقر على userform1 يفتح بس لزم يفتح ضمن الuserform الرئيسي مش حر ذي ما بيظهر شكرا على المشاركه

السلام عليكم ورحمة الله وبركاته,, تحية شكر وتقدير للاخ الكريم ابو محمد على طرح هذا الموضوع الرئع والذي بلا شك عرف وسهل الكثير من الخطوات في تحويل الاكسس الى sql server,, كما اعجبني طريقة الطرح السلس وسعة صدره في الرد على استفسارات المتابعين,, جعله الله هذا العمل في ميزان حسناتك لدي استفسار ماذا لو كان جهاز العميل موجود في مكان اخر بعيد عن الشبكة المحلية....كيف يمكن الاتصال بالسيرفر عن طريق الانترنت وعمل مشاركة مع قاعدة البيانات؟

السلام عليكم إضغط مرتين متتاليتين في أي ورقة على الخلية A1 book1-1.rar

تم التحديث اكثر للملف بحيث يظهر الصف الاول في كل صفحة عند الطباعة و البرنامج يتلافى الاخطاء المطبعية في اختيار عدد الصفوف ويدرج محموع اخر صفحة (حتى و لو كانت تحتوي على صفوف اقل من الصفوف المختارة) لادراج معاينة قبل الطباعة - اضغط Ctrl+ F2 طباعة ذكية salim 2.rar

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

السلام عليكم و رحمة الله أخي أبو عبد الرحمان أولا : قم بتحديد كامل العمود E و اضبط محاذات الخلية كما تريد ثانيا : بداخل الكود هناك سطران بقوم الاول بتفريغ محتوى الورقة الاولى و الثاني يفرغ الورقة الثانية إلا إذا أردت زر آخر وظيفته مسح البيانات فقط ثالثا : بقيت ساعات على حلول عيد الفطر المبارك ، لذلك اقول لكم تقبل الله منا ومنكم صالح الأعمال ، و أعاده علينا و عليكم و على كل الأمة الاسلامية بالخير و اليمن و البركاة

حبيبى أبو حنين السلام عليكم ورحمته والله وبركاته ياأخى لما الدماغ بيركب بيبقى حاجة صعب من الامس وهية راكبة معايا على FormatNumber بينما الصواب هو NumberFormat هناك ملاحظة تخص العمود E بالورقة " ملف الدفع الإلكترونى " ستلاحظ أن الخلية E 8 دائما تأتى يمنيا تارة وتارة أخرى يسارا أما باقى خلايا العمود فتأتى يسارا " وربنا يجعلنا من أهل اليمين " الاضافة الأخيرة بعد إذنك أخى الحبيب كود من شأنه مسح محتوى كلا الورقتين ABOHANIN و " ملف الدفع الإلكترونى " فى أن واحد تمهيدا لاستقبال بيانات جديدة تقبل الله منا ومنكم صالح الاعمال **** وجزاكم الله خيرا

السلام عليكم ورحمة الله أساتذتنا وأصدقائنا الكرام في هذ الصرح العملاق والمتميز دائماً في فعل ونشر المعرفة والخير للجميع اليوم أتيت لكم ببرنامجي البسيط والمتواضع الذي ولله الحمد قد قمت ببرمجته في عام 2015 وأستخدمته أحدى شركات المقاولات التي تحتوي مايقارب عن 500 موظف في الأونة الأخيرة تم نشر برامج كثيرة حول مجال شؤون الموظفين والمرتبات ولكن كانت تقتصر فقط على مبدأ أرشفة بيانات الموظفين ولكن الآن تستطيع أخي المستخدم غير ذلك بكثير ، وهي إضافة المرتب لكل موظف في حسابه حسب اختيار المستخدم لفترة استحقاق المرتب له وعند دخول وقت الاستحقاق يقوم البرنامج بالتنبيه وتذكيرك بسحب المرتبات وأيضاً تستطيع إضافة حركات مالية أخرى كنظام السلف والدفعات والمسحوبات على المرتب وميزات كثيرة سوف تكتشفها بنفسك عند الاستخدام . قمت بإضافة نظام الحماية المتميز وهو تفعيل النسخة بالرقم التسلسي للوحة الأم بحيث تعمل النسخة على جهاز واحد فقط وعند النقل يتم قفل البرنامج عن العمل صور من البرنامج صورة تفعيل البرنامج روابط التحميل Office Soft.Employ & Salary أو Office Soft.Employ & Salary فيديو شرح التنصيب والتثبيت من هنا فيديو طريقة ألية عمل واستخدام البرنامج من هنا الشرح التفصيلي للبرنامج موجود في مجلد البرنامج بعد تثبيته على جهاز الكمبيوتر ملاحظة مهمة :يرجى عدم تغيير مسار تنصيب البرنامج لكي يعمل معكم بشكل كامل أو تنصيبه في مسار أخر غير القرص الصلب (C) البرنامج تم تجربته على أوفيس 2010 و 2007 ويعمل بشكل كامل ومتميز أتمنى أن ينال أعجابكم والحمد لله

أخي الكريم محمد علي ضع الكود التالي في موديول عادي Sub ShowForm() UserForm1.Show End Sub Function LastRowPic(ColumnNumber As Long) As Long Dim Arr, Pic As Shape, I As Long ReDim Arr(1 To Columns.Count) For Each Pic In ActiveSheet.Shapes With Pic For I = .TopLeftCell.Column To .BottomRightCell.Column Arr(I) = Application.Max(.BottomRightCell.Row, IIf(Arr(I) = "", 0, Arr(I))) Next I End With Next Pic LastRowPic = Arr(ColumnNumber) End Function ثم قم بوضع الكود التالي في حدث الفورم #If VBA7 Then Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #Else Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #End If Private Const SW_HIDE As Long = 0 Private Const SW_SHOW As Long = 5 Private LastSelectedFilePath As String Private Sub CommandButton1_Click() Dim strFileName As String strFileName = Application.GetOpenFilename(FileFilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select A File", MultiSelect:=False) If strFileName = "False" Then MsgBox "File Not Selected!" Else Me.Image1.Picture = LoadPicture(strFileName) LastSelectedFilePath = strFileName Me.Repaint End If End Sub Private Sub CommandButton2_Click() Dim R As Range, LR As Long ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_HIDE If LastRowPic(22) = 0 Then LR = Cells(Rows.Count, "V").End(xlUp).Row + 1 Else LR = LastRowPic(22) Set R = Range("V" & LR) ShowWindow FindWindow("ThunderDFrame", Me.Caption), SW_SHOW With ActiveSheet.Pictures.Insert(LastSelectedFilePath) .ShapeRange.LockAspectRatio = msoFalse .Top = R.Top .Left = R.Left .Width = R.Width .Height = R.Height End With End Sub وإليك الملف المرفق فيه تطبيق للأكواد أرجو ان يكون المطلوب إن شاء الله Load Picture On UserForm Using Dialog & Insert Image To Worksheet YasserKhalil.rar

عمل مميز من شخص مميز

أنت بالفعل رائع يا حبيبى يا أخى الفاضل / ياسر زادك الله من العلم الكثير والكثير

مشكور ولك خالص تحياتي

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

كود قائمة منسدلة متناقصة كود قائمة منسدلة متناقصة.rar