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

جرب المرفق Select Case DataErr Case 3201 MsgBox "اكتب الرسالة التي ترغب تجد الكود في حدث عند الخطأ", , "تنبية" Response = 0 End Select استخدمنا Case حتى يمكن اضافة رسائل اخطاء اخرى لو وجدت Items9-27.accdb

انظر الى هذا الملف aaشيت.xlsm

جرب هذا الماكرو Option Explicit Sub del_rows() Dim arr() Dim y%, i% Dim Rg As Range With Sheets("ورقة1") y = Cells(2, Columns.Count).End(1).Column If y < 5 Then Exit Sub arr = Application.Transpose(.Cells(2, 5).Resize(, y - 4)) arr = Application.Transpose(arr) For i = LBound(arr) To UBound(arr) If IsNumeric(arr(i)) Then If Rg Is Nothing Then Set Rg = .Cells(arr(i), 1) Else Set Rg = Union(Rg, .Cells(arr(i), 1)) End If End If Next i Rg.Rows.Delete End With End Sub

يا سيدي (لان العداد يبدأ من الخلية A2 ) اي ان الصف 2 رقمه 1 بنظر المعادلة أضف واحد على المعادلة =IFERROR(MATCH(A2,$B$2:$B$194750,0)+1,"Not Found")

- موديول إخفاء إطار الأكسس - التوسيط - التصغير بجوار الساعة - تغيير الأيقونة - استدعاء بيانات ورسائل من جدول تم وضع التذكيـــر الاتى برأس الموديول لسهولة التعامل مع الأكودا واستدعائها 'icon path >>---> CurrentProject.Path &"\"&"\File Library\Fav Ico\Myicon.ico" 'Hide Access >>---> CallStartForm() 'CenterObjects >>---> Call CenterFrm(Me) 'Minimize To Systray >>---> Call AppMini() 'To Quit Application >>---> Call AppQuit() 'To Close Any Forms >>---> Call AppCloseFrm() 'Application Name >>---> Call AppName() 'Designer Name >>---> Call DesName() 'Designer Phone >>---> Call DesPhone() 'Designer Email >>---> Call DesEmail() 'call Any Message From Table '>>>>> StrMyCriteria = "MyCriteria ='xxxx'" '>>>>> MyMesg (txtOfMesg), vbOKOnly, strMsgTitle '>>>>> Change "xxx" By Criteria From Table >> UsystblUsefulData << By Criteria From Field [MyCriteria] '>>>>> Example MyCriteria >>---->> msgDesData '>>>>> StrMyCriteria = "MyCriteria ='msgDesData'" '>>>>> MyMesg (txtOfMesg), vbOKOnly, strMsgTitle هذا المرفق الاول بدون عمل اختصار للبرنامج Utilities Hide Ico Minimze To SysTray.zip --------------------------------------------------------------- هذا المرفق للإضافة إختصار أليا الى سطح المكتب وتحكم كامل فى كل ما يخص الاختصار من الجدول UsystblUsefulData اسم الاختصار الوصف مفتاح الاختصار من الكيبور لفتح التطبيق وفى حالة عدم وجود اى بيانات بالجدول تخص الاختصار او عدم وجود ايقونة فى المسار المخصص يتم استخدام البيانات الاساسية والايقونة الاساسية Utilities Hide Ico Minimze To SysTray V.02.zip

شرح UserForm Spreadsheet تحياتي إلى الجميع شرح UserForm Spreadsheet هذه الأداة تسمح بنسخ كامل ورقة العمل او مدي محدد منها الي الفورم مع التحكم في الجزء المنسوخ بالتسيق للصفوف والأعمدة والتلوين واشياء كثيرة اخري هذه الاداة UserForm Microsoft Spreadsheet Control ActiveX من ادوات Control ActiveX وهي تتوفر لمستخدي اوفيس 11 و 14 أي لمستخدمي اوفيس 2003 و 2010 بدون اى مشاكل ================================================== اما مستخدمي اوفيس 2007 اما تركيب owc11 Office Web Components الخاصه بأوفيس 11 بدلا من Excel Services ورابط تحميلها من Microsoft موجود بالمرفقات_1 او فأذا لم تعمل الاداة يجب تنفيذ التعليمات التاليه وهي طريقتين بالرابط التالي رابط التعليمات بالمرفق_2 ================================================== المرفقات_1.rar المرفقات_2.rar يتبع اظهار الاداة لمستخدمي اوفيس 2003 و 2010 سوف نتبع كل السبل المتاحه لإظهر الادة الطريقة الاولي اتبع الصور من 1 - 4 في محرر الاكواد الطريقة الثانية اتبع الصور من 5 - 6 في محرر الاكواد بعد اضافة المكتبتين نفذ ما في الصور من 1 الي 4 اذا لم تجد هاتين المكتبتين لا عليك قم بتحميل المرفق_3 ستجد بداخله ملف اكسيل بأسم Add_Reference اضغط علي الزر لتنفيذ ماكرو يعمل علي اضافة هاتين المكتبتين بعد اضافة المكتبتين عن طريق الماكرو نفذ ما في الصور من 1 الي 4 ================================================== المرفقات_3.rar يتبع

السلام عليكم ورحمة الله تعالى وبركاته احبائى اقدم لكم هذه الاداة البسيطة ذات الفائدة الكبيرة احيانا تحدث مشكلة عند تشغيل قاعدة بياناتك على بعض الأجهزة وذلك بسبب كتابة الحروف العربية داخل محرر الاكواد اثناء التصميم حتى وإن كانت ملاحظات وتلميحات وتم تعطيلها وبين طيات نقاش طويل بينى وبين استاذى الجليل ومعلمى القدير ووالدى الحبيب الاستاذ @jjafferr نصحنى وشدد على بــــ عدم كتابة اى احرف عربية داخل المحرر حتى وان كانت ملاحظات او تلميحات فسألته : وماذا ان اردنا كتابة رسالة باللغة العربية فأجابنى : بعمل جدول ليتم كتابة ما تريد باللغة العربية وتستدعيه وقت الحاجة فكرت وحاولت وبفضل الله تعالى ثم مساندة أستاذى الجليل فيما تعثرت فيه وتوصلت الى ذلك ولكن هناك شقين 1- الموضوع مرهق قليلا ويتطلب وقت وجهد كبيرين 2- بالرغم من النقطة السابقة الا انه ممتع جدا جدا جدا وبرغم صعوبته اثناء التصميم الا انه يعطى مرونه فى تغيير الرسائل بدون الرجوع الى محرر الاكواد وطبعا قد لا يستطيع البعض تحقيق ذلك لذلك فكرت فى بديل وكانت بفضل الله تلك الاداة البسيطة التى اضعها الان بين اياديكم شرح الاداة نكتب ما نريد فى المكان المخصص للغة العربية ونقوم بتحويل ما كتبناه الى الترميز العالمى نقوم بعمل نسخ الترميز العالمى الى محرر الاكواد داخل قاعدتك فى المكان المحدد لذلك من واقع الصورة الجزء الأيمن 1 >>---> المكان المخصص لكتابة اللغة العربية 2 >>---> زر الامر الذى يقوم بتحويل ما تم كتابتة الى الترميز العالمى Unicode 3 >>---> زر الامر الذى يقوم بنسخ الاحرف التى تم تحويلها الى الترميز العالمي الجزء الأيسر A >>---> لصق الترميز العالمى الذى قمت بنسخه من اى قاعدة بيانات تم استخدام هذا الترميز فيها من قبل B >>---> زر الامر الذى يقوم بتحويل الترميز العالمى Unicode الى اللغة العربية لتستطيع قراته مرفق لكم الاداة + قاعدة تجربة انتظر تجربتكم وافادتكم تم تعديل المرفق فى تمام الساعة 7:44 م بتوقيت القاهرة - تاريخ 23/09/2019 Converter Arabic and Unicode.zip Converter Arabic and Unicode.mdb

وعليكم السلام الملف يعمل بالفيجوال تفضل test2.xlsm

وعليكم السلام فين الملف ؟!!!! لا يمكن المساعدة بدون الملف فلا يمكن العمل على التخمين ولا تكتمل اى مشاركة الا برفع الملف ..... تم التنبيه عن ذلك مئات المرات

نعم استادي سليم هذا صحيح

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

أحسنت استاذ حسين كود رائع بارك الله فيك استاذ سليم ولكن يحدث مشكلة عند تطبيق كود حضرتك عند هذا السطر Set Rg = Union(Rg, .Cells(arr(i), 1))

جرب المرفق لعله يفي بالغرض خيثر.xlsm

الف شكر Ali Mohamed Ali جزاك الله خير لا حرمنا الله منك

وعليكم السلام تفضل-تم فك حماية الملف , فالملف الأن بدون حماية 1معادلات.xlsx

عفوا أخي مازلت طالب العلم.. تفضل أخي بعد تعديل الملف كلمة المرور 123 HideMessage (1).accdb

بعد اذن اخي الفاضل @YaSiN Abdullahi جرب المرفق كلمة المرور 1234 HideMessage.accdb

السلام عليكم جرب هذا المرفق لقراءة الباركود تبع المشكلة barcode.rar

جرب هذا المعادلة واسحب نزولاً =IF(OR(D2="",D2="Not Found"),"",INDIRECT("B"&D2))

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

وعليكم السلام ورحمة الله وبركاته. تفضل أخي الحبيب HideMessage.accdb

حبيبنا استاذنا ابو ياسين لاداعي للاعتذار اخوك الصغير مواقفك لاتنسي جزاك الله خير

المعذرة على سوى الفهم

لاجل عينك استاذ عصام BackUp.rar

السلام عليكم كما عودناكم على الامور الجديدة والمفيدة هذا الكود مهم جدا حيث عندما تفتح برنامج الاكسس تظهر نافذة النموذج الرئيسي فقط كل الشكر للغالي @ابو ياسين المشولي فهو صاحب هذا الكود مرفق ملف العمل للتطبيق اخفاء اكسس (2).accdb

بارك الله فيك اخي عبداللطيف

كما قيل سابقا ...خير من أن تعطيني سمكة علمني الصيد أنا اشرح لحضرتك كيف تقوم بعمل واجهة احترافية لبرنامجكك ببساطة اولا قم بالبحث في محركات البحث المختلفة على الانترنت عن صور جيدة تصلح أن تكون واجهة لبرنامجك ويمكنك ببعض التعديلات عليها سواء باستخدام الفوتوشوب أو حتى ببرنامج الpaint أن تجعلها مناسبة لبرنامجكك تماما ثم ضعها في نموذج ويفضل ان تجعلها كصورة مرتبطة حتى لا تستهلك مساحة كبيرة من البرنامج بحيث تضعهافي فولدر بجوار برنامجك أو فولدر فرعي تسميه img أو ico أو sys .....الخ شيء من هذا القبيل ثم تستخدم كود صغير يستدعيها عند فتح النموذج الرئيسي لواجهة المستخدم ولا تنسى أن تضع عليها مربعات نص فارغة شفافة بالنقر عليها تقوم بتنفيذ الاكواد الخاصة بفتح وغلق النماذج المختلفة واداء الأوامر طبقا لبرنامجك وهكذا يمكنك ببساطة أن تقوم بعمل واجهات تماثل افضل البرامج الاحترافية الموجودة في السوق بل وتتفوق عليها ويمكنك أن تستخدم نفس الفكرة في عمل أزرار أو مفاتيح أو شريط ادوات تستخدمه في باقي النماذج ......وهكذا

في هذا الملف نموذج عما تريد فقط اكمل المصفوفة بما تشاء من اختصارات و ما يقابلها من اسماء ونفذ الماكرو Option Explicit Sub replace_Please() Dim my_rg As Range Dim arr(1 To 3) Dim st$ Dim i% arr(1) = "مصط" & "*": arr(2) = "حس" & "*": arr(3) = "عيد" & "*" Set my_rg = Range("f1").CurrentRegion For i = LBound(arr) To UBound(arr) Select Case arr(i) Case "مصط" & "*": st = "مصطفى" Case "حس" & "*": st = "حسين" Case "عيد" & "*": st = "عبد" End Select my_rg.Replace What:=arr(i), Replacement:=st, LookAt:=xlPart Next End Sub الملف مرفق Replacement.xlsm

جرب هذا المعادلة في الخلية D2 ثم اسحب نزولاً =IFERROR(MATCH(A2,$B$2:$B$194750,0),"Not Found") اذا لم تعمل معك المعادلة استبدل الفاصة بفاصلة منقوطة لتبدو المعادلة بهذا الشكل =IFERROR(MATCH(A2;$B$2:$B$19475;0);"Not Found")

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

اتفضل تقدر طبعا تكمل انت المشوار انا نفذت لك الكود على فتح نموذج عملية انتاج فتح النموذج بنافذة اخرى.accdb

اكثر جمل الاتصال الآمن استخدمها تكون على النحول التالي في رأس موديل الفورم Option Explicit Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Const SW_HIDE As Long = 0 Private Const SW_SHOWNORMAL As Long = 1 الاتصال ( اضف الأيبي + اسم المستخدم + كلمة المرور ) ShellExecute Me.hwnd, "Open", "C:\Windows\System32\mstsc.exe", "/P pinghost=Enter server IP address: '' \\%pinghost% /user:''\username ''", "C:\", SW_SHOWNORMAL اذا استطعت الاتصال و الدخول لسطح المكتب يصير الأمر بسيط فقط بتعديل السطر اعلاه

اخوي جرب بهذي الطريقة و اعطيني خبر ايش يصير معاك بحيث لو ماضبط فكرة اخرى عند محاولة الدخول يتم زراعة باتش و اعتقد هذي اسهل طريقة لتمرير معلومات الدخول "\\192.168.1.2\Pro\IP.accdb" & "UserName" & "password"

اتفضل فتح نموذج اكثر من مرة.accdb

اولا- الجدول كما يفهمه برنامج الاكسل هو مجموعة من البيانات لا تحتوي على خلايا فارغة ولا مدمجة للغة العربية 1-الى يمينها عامود فارغ او حد الصفخة الايمن 2- الى يسارها عامود فارغ 3-فوقها صف فارغ او حد الصفحة الاعلى 4- تحتها صف فارغ كلمة واحدة الجدول كما يفهمه برنامج الاكسل مجموعة بيانات مستقلة في نطاق لا يجمعها شيء مع غيرها لذلك كي يعمل الماكرو بشكل جيد قمت بتعديل الجدول بوضع صف فارغ في الاعلى (الصف رقم 6) و ازالة الدمج من البيانات لذا ارجو التقيد بهذه المعلومات عند ادراج اي جدول للعمل معه بمنتهى السهولة الكود Option Explicit Sub copy_filter() Dim M As Worksheet: Set M = Sheets("مفرد الراتب") Dim One As Worksheet: Set One = Sheets("1") If M.FilterMode Then M.ShowAllData: M.Range("B7").AutoFilter End If One.Range("B7").CurrentRegion.ClearContents M.Range("B7").AutoFilter Field:=3, Criteria1:="<>0", _ Operator:=xlOr, Criteria2:="=المبلغ" M.AutoFilter.Range.Copy _ One.Range("B7") On Error Resume Next M.ShowAllData: M.Range("B7").AutoFilter End Sub الملف مرفق MOUFRADAT.xlsm

السلام عليكم أكيد يمكن طباعة جميع التقارير من القائمة المنسدلة بدلًا من طباعتها بشكل مفرد، ويمكن أيضا طباعة جميع التقارير باستعمال خاصية "من.... إلى...." (من الاسم1 إلى الاسم2)... بن علية حاجي تجربة - طباعة.xlsm

السلام عليكم جرب المرفق اضغط فوق الزر الأحمر بالزر اليمين للفأرة سوف تظهر لك قائمة بها ثلاثة عناصر كل عنصر له أمر معين تستطيع التعديل على الأوامر و المسميات من الوحدة النمطية و وحدات الماكرو الكود.rar

السلام عليكم تجنبا لكثرة النطاقات بالتسمية حسب عدد المواد، ارتأيت أن أغير طريقة تحديد القوائم المنسدلة لمعلمي المواد بتسمية واحدة Profs_Mat اعتمادا على تسميتين Cellule (قائمة المواد من العمود Y) والتسمية Mat (اسم المادة المستعمل في البيانات من العمود Z) حسب اختيار المادة من الخلية E6 المرتبطة بالتسمية Cellule... بالنسبة لخلايا "أسماء المدرسين" في الجدول تم استبدال القوائم المنسدلة فيها بمعادلات بالدالة INDEX حتى يتم تغيير هذه الأسماء (أسماء المدرسين) تلقائيا حسب اختيار المادة من الخلية E6... أرجو أن تفي هذه التعديلات الغرض المطلوب... بن علية حاجي النطاقات (2).xlsx

جزاك الله خيرا أخي الكريم بن علية ، رزق الله الجزائر وأهلها الكرام نعمة الأمن والأمان

السلام عليكم حل بالمعادلات في المرفق... ن علية حاجي معدل التقدير.xlsx

السلام عليكم ورحمة الله انسخ هذين الكودين وضعهما فى حدث ThisWorkbook Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",true)" Application.DisplayFormulaBar = True ActiveWindow.DisplayHeadings = True Application.DisplayScrollBars = True Application.DisplayStatusBar = True End Sub Private Sub Workbook_Open() Application.ScreenUpdating = False Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",false)" Application.DisplayFormulaBar = False ActiveWindow.DisplayHeadings = False Application.DisplayScrollBars = False Application.DisplayStatusBar = False Application.ScreenUpdating = True End Sub

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

السلام عليكم حل أول بالمعادلات... بن علية حاجي mo.xlsx

باختصار عند فتح القاعدة البيانات سيفتح بشكل اوتوماتيكي الماكرو باسم AutoExec وذاك الماكرو بيعمل اوبديت اي تحديث للجدول ويخزن فيه دقة الشاشة و سيتغير دقة الشاشة الى 1024 * 600 بعد ذلك سيفتح نموذج فورم 2 وعند فتحه سيتم فتح معه نموذج FrmOpenInOpenDB بشکل مخفي وعند اغلاق القاعدة سيتم اغلاق النموذج المخي وفي حالة اغلاق نموذج المخفي سيتغير دقة الشاشة الى دقة الشاشة الاصلية اللي المخزنة في الجدول اي نعم

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

مرحبا بك معنا يا ابن الأوراس أو الهضاب العليا. لم نعهد على أبناء محاربي الصحراء الخوف. فكلنا هنا تارة نستفيد و تارة أخرى نفيد بما علمنا الله سبحانه و تعالى.

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته تحياتي إلى الجميع تكملة شرح UserForm Spreadsheet قبل عمل ال TextBox لنستخدمه في البحث او الفلترة سنقوم بعمل بعض التحابيش الجماليه لل Spreadsheet وهي اخفاء لبعض الاشرطه والادوات من ال Spreadsheet لتبدو لنا مثل ListBox تماما كما في الصوره التاليه سيتم اخفاء كل الاشرطة والادوات التي تم تميزها باللون الاحمر ويتم ذلك بأستخدام اجراء تنشيط UserForm وهو UserForm_Activate وتكون الاكواد كالاتي ================================================== Private Sub UserForm_Activate() ' '================================================================== With Spread .DisplayToolbar = False ' اخفاء شريط الادوات With .ActiveWindow .DisplayWorkbookTabs = False ' اخفاء تاب اوراق العمل .EnableResize = False ' اخفاء تاب التحكم في حجم ورقة العمل .DisplayHeadings = False ' اخفاء ترقيم الصفوف و الاعمدة .DisplayHorizontalScrollBar = False 'اخفاء شريط التمرير الافقي .DisplayVerticalScrollBar = False 'اخفاء شريط التمرير الرأاسي End With End With '================================================================== ' End Sub ================================================== والان نكمل المثال بعد تم عرض كامل الدتا داخل Spread 1 - سنقوم بعمل زر للخروج طور الفورم 2 - سنعمل عدد 2 TextBox احدهما للبحث او الفلترة والثاني لمجموع مبالغ المكافئة 3 - سنعمل عدد 2 OptionButton الاول للفلترة من بداية الاسم والثاني للفلترة بأي جزء من الاسم وتكون الاكواد كالاتي في حدث TextBox1_Change كالاتي عند ادراج اى حرف في TextBox1 يبدأ تنشيط هذا الحدث ================================================== Private Sub TextBox1_Change() ' On Error GoTo End_Me Spread.Rows("1:" & Rows.Count).ClearContents 'حذف محتويات ال Spread بالكامل ' '/============================================================= Search_Text = TextBox1 & "*" 'في حالة تنشيظ ال OptionButton1 'توجيه محتوي ال TextBox1 الى المتغير Search_Text 'واضافة علامة النجمة له في نهايته ليكون البحث او الفلترة بجزء من بداية الاسم If OptionButton2 Then Search_Text = "*" & TextBox1 & "*" ' اما في حالة تنشيظ ال OptionButton2 'توجيه محتوي ال TextBox1 الى المتغير Search_Text 'واضافة علامة النجمة له في البداية و النهايته ليكون البحث او الفلترة بأي بجزء من الاسم ScreenOn Sh_Data.Range("A1").AutoFilter Field:=2, Criteria1:=Search_Text 'في ورقة العمل الرئيسية عمل تصفية تلقائية على العمود الثاني (الاسم) 'بمحتوي متغير الفلترة المتغير Search_Text '/============================================================= Sh_Data.AutoFilter.Range.Copy 'بعد الفلترة نسخ ناتج الفلترة من ورقة العمل الرئيسية الي الذاكرة With Spread With .Range("A1") .Paste 'لصق ناتج الفلترة الي ال Spread .Select End With End With '/============================================================= Total = Sh_Data.Range("M1").Value TextBox2 = CStr(Format(Total, "0.00")) 'نسج خلية المجموع ( M1 ) من ورقة العمل الرئيسية الي TextBox2 في الفورم '/============================================================= End_Me: ScreenOn On Error GoTo 0 ' End Sub ================================================== ملحوظة بعد عمل الفلترة على الفورم يمكن التبديل بين بداية الاسم و أي جزء الاسم الملف موجود بالمرفقات_6 تم تجربة المثال علي كل من أوفيس 11 / 2003 و أوفيس 14 / 2010 بدون أي مشاكل وبذلك ينتهي شرح UserForm Spreadsheet والي لقاء قريب بإذن الله مع شرح اداة ثانية نادرة الاستخدام مغمورة مطمورة ================================================== المرفقات_6.rar تحياتى لكم جميعا

والان نبدأ استخدام الاداه بعد تجهيز الملف بجدول البيانات في اول ورقة وايضا بعد تجهيز الملف بال UserForm وادراج الاداة Spreadsheet فى UserForm نبدأ بكتابة الاكواد داخل اجراء البداية لل UserForm وهو اللاجراء الاولي الذي يعمل عند بداية تنفيذ استدعاء ال UserForm وهو UserForm_Initialize وتكون الاكواد كالاتي ================================================== Dim Sh_Data As Worksheet Dim Rng As Range Dim Spread As OWC11.Spreadsheet ' Private Sub UserForm_Initialize() ' Set Sh_Data = Sheets("Data") Set Spread = UserForm1.Spreadsheet1 OptionButton1 = True OptionButton2 = False CommandButton1.Caption = "خـــــروج" ScreenOff '====================================================================== End_Row = Sh_Data.Cells(Rows.Count, "A").End(xlUp).Row 'تحديد رقم اخر صف في ورقة الدتا Set Rng = Sh_Data.Range("A1:K" & End_Row) 'تحديد مدي قاعدة البيانات '====================================================================== Rng.Copy 'نسخ مدي قاعدة البيانات ' With Spread ' With .Range("A1") .Paste 'لصق مدي قاعدة الي شيت الفورم بدء من الخليه A1 .Select End With ' Application.CutCopyMode = Fals .Cells.AutoFit 'احتواء تلقائي لشيت الفورم ' With .ActiveWindow .ViewableRange = Rng.Address 'اجبار شيت الفور علي اظهر مدى قاعدة البيانات فقط لعدم استهلاك الذاكره 'انا اعمل علي اوفيس 2003 ليتوافق مع جميع نسخ الاوفيس 'وهو يحتوي علي صفوف عددها هو 35536 صف 'و يحتوي علي اعمدة عددها هو 256 عمود 'اما داخل ال Spread في UserForm 'فهيي تحتوي علي صفوف عددها هو 262144 صف 'أي عدد الصفوف يساوي 4 امثال ورقة العمل العادية 'و تحتوي علي اعمدة عددها هو 18278 عمود 'أي عدد الاعمدة يساوي 72 ضعف ورقة العمل العادية 'تخيل حجم الذاكرة المستهلكة 'فهذا السطر يجبر ال Spread علي عرض مدي قاعدة البيانات فقط 'تخيل حجم الذاكرة التي تم توفيرها End With ' .RightToLeft = True 'جعل شيت الفورم من اليمين الي اليسار ' End With '====================================================================== Change2Arabic ' End Sub ================================================== المثال_1 بالمرفقات_4 تم تجربة المثال علي كل من أوفيس 11 / 2003 و أوفيس 14 / 2010 بدون أي مشاكل ================================================== المرفقات_4.rar يتبع بعد حفظ الملف و إعادة فتحه مرة اخري ستظهر رسالة تحذيريه من ActiveX Control لأيقاف ظهور هذه الرسالة ينفذ ملف الريجيستري التالي الموجود بالمرفقات_5 الي ان نلتقي مع تكملة المثال ================================================== المرفقات_5.rar يتبع

السلام عليكم ورحمة الله وبركاته قمت بعمل برنامج بسيط للتعامل مع التقويم الهجري والتقويم الميلادي وذلك حسب تقويم أم القرى المعتمد في المملكة العربية السعودية وهذا البرنامج يعطيك تقويم سنوي أو شهري هجري أو ميلادي من عام 1318 إلى 1450هـ كما يقوم البرنامج بتحويل التاريخ من هجري إلى ميلادي والعكس وكذلك يقوم البرنامج بحساب التاريخ بين تاريخين وإضافة أو نقص إلى تاريخ محدد أرجو تحربته وإبداء آراءكم فيه فرأيكم مهم عندي http://www.4shared.com/file/T8gP9EFL/taqwem.html ولكم خاص تحياتي