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

السلام عليكم ورحمة الله وبركاته الفرق بين تاريخين باستخدام الدالة DATEDIF اتمنى ان يفيدكم جميعا تعريف الدالة امثلة على استخدام الدالة مدونة خبير اكسيل http://excelfinancial1.blogspot.com.eg/ تحميل الملف الفرق بين تاريخين.rar

أخي الكريم الياسر جرب الكود التالي Sub Test() Dim LR As Integer LR = Cells(27, 1).End(xlUp).Row + 1 Range("A" & LR & ":F" & LR).Value = Range("A3:F3").Value End Sub تقبل تحياتي

السلام عليكم ورحمة الله وبركاته أخي الحبيب ياسر نبارك لك بالمشاركة 8888 ونرجو الله لك أن تكون مشاركاتك النافعة حتى تكون 888888888888 وأنت بخير وسلامة أنت وكل أحبتي فهذه المشاركة لأخي محمد الريفي جعلتني أنظر إلى قطار العمر الذي مر سريعاً 50 سنة و9 أشهر و 2 يوماً نرجو الله أن يختم لنا بالحسنى والسلام عليكم.

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

السّلام عليكم و رحمة الله و بركاته حاول أخي الكريم إتّباع هذه الصّور لعلّها تفي بالغرض ..

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

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

السلام عليكم ورحمة الله وبركاته إخوتي وأساتذتي الكرام: جزاكم الله خيراً على دروسكم القيمة رأيت أن أسد جانباً من الثغرة التي تركها فقدان الملف بهذه الصورة التي أرفقها والسلام عليكم. تم حذف المرفق بعد إرفاق الملف من أستاذنا محمد الريفي لأنه إذا حضر الماء بطل التيمم.

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله مع التحديث الجديد .. للأسف لم أجد التوجيهات التي تم وضعها من قبل ، وهذه القواعد والأسس هامة جداً ليدرك الأعضاء كيفية التعامل مع المنتدى طبعاً الموضوع سيكون متجدد .. سيتم وضع القواعد مرة أخرى فالرجاء الرجاء أن تساعدوني في اتمام الأمر .. كل عضو يذكرني بتوجيه من هذه التوجيهات ليتم إرساء القواعد ، إذ أن نجاح أي مؤسسة يعتمد في المقام الأول على قواعد ومنهج ثابت للسير على دربه التوجيهات والقواعد التي يجب مراعاتها التوجيه الأول : قبل طرح موضوع جديد يتعلق بطلب محدد يرجى استخدام خاصية البحث أولاً ، فإذا لم يجد طارح الموضوع بغيته ، فعليه أن يقوم بطرح موضوع جديد ، وفي هذه الحالة على طارح الموضوع أن يعلم أن حسن السؤال شطر الإجابة ، فاللباقة واللياقة والكياسة من الصفات التي يجب أن يتحلى بها طالب العلم. التوجيه الثاني : عند طرح موضوع جديد ، يتم وضع عنوان مناسب للطلب بحيث يفهم الطلب قبل الإطلاع عليه ، وعلى طارح الموضوع أن يبتعد عن العناوين الغير مجدية مثل : ( طلب مساعدة - الرجاء المساعدة - ساعدوني من فضلكم - عاجل وهام - الحقوني - نداء للعباقرة - نداء للعمالقة - إلى آخر تلك العناوين ...) ، وأمر آخر ألا يكون العنوان على شكل سؤال أو طلب .. نبتعد عن كلمة "طلب" مثال تطبيقي : نفترض أنني أريد معادلة تجمع القيم في عمودين العنوان المناسب للطلب يكون بهذا الشكل : معادلة جمع القيم في عمودين والنتائج في عمود آخر التوجيه الثالث : أن يتم توضيح المطلوب بالموضوع بشكل يزال معه أي لبس ، وفي نفس الوقت يراعى الإجمال في الطلب ، فأقصر الخطوط هو الخط المستقيم ، بمعنى "لا إطالة مملة ولا اختصار مخل" ، أي لا يكون طرح الموضوع مختصر للغاية بل يجب أن يستوفي جميع العناصر المطلوبة ، ومن ضمنها أن يحدد طارح الموضوع هل الحل المطلوب بالمعادلات أم بالأكواد أم بكلاهما لتكون الأمور واضحة بالنسبة لمن يريد تقديم المساعدة ، وأن يقوم صاحب الموضوع بإرفاق ملف به بيانات وهمية لتوضيح طلبه وللوصول إلى حل سريع ودقيق ، وإذا صعب على طارح الموضوع شرح المطلوب يمكنه إرفاق بعض النتائج المتوقعة كي يسهل الوصول لحل. التوجيه الرابع : نلاحظ أن شكل المنتدى لا يعجب معظم الأعضاء ، فلما لا نغير بأيدينا الشكل العام للمشاركات ، فيفضل على سبيل المثال استخدام حجم خط كبير 22 على سبيل المثال وجعل الخط عريض Bold مما يجعل المشاركة واضحة ومقروءة بشكل جيد ، كما يمكن استخدام الألوان أي قم بتنسيق المشاركة بشكل جذاب يجعل القاريء لا ينفر منها. التوجيه الخامس : بعد الانتهاء من الموضوع والوصول لحل يرضي صاحب الموضوع ، يرجى أن يتم تحديد أفضل إجابة من خلال النقر على علامة الصح الموجودة بجانب كل مشاركة ، وأن يسجل صاحب الموضوع إعجابه من خلال النقر على "سجل اعجاب بهذا" كنوع من رد الجميل لمن قدم المساعدة ، ويمكن أيضاً أن يقوم بتقييم المشاركة تقييم إيجابي كنوع من التقدير ، وأن تشكر من قدم المساعدة فمن لم يشكر الناس لا يشكر الله. فيما يخص لو كان هناك أكثر من إجابة للموضوع ، يمكن لصاحب الموضوع عمل مشاركة جديدة يجمع فيها كل الحلول ويختار هذه المشاركة كأفضل إجابة التوجيه السادس : لا تكن لحوحاً ، يكفي أن أعضاء المنتدى يقدمون وقتهم و خبرتهم مقابل لا شيء وعندهم أعمال أخرى (مشاغلهم الخاصة) يقومون بها ، و إذا تأخر الرد ، فمن الممكن أن يكون أحد الأعضاء يقوم بمحاولة الإجابة ، وهذا يستغرق بعض الوقت خاصةً إذا كان الموضوع صعباً. التوجيه السابع : حمل الملف المرفق دون زركشات (ألوان و تنسيقات مختلفة) مما يزيد من حجم الملف و أحياناً تكون الألوان مقززة بشكل ينفر منها المساعد (خاصةً إذا كانت ألوان الخلايا غير متناسقة مع لون الخط) التوجيه الثامن : تأكد أن الملف المرفوع غير مصاب بفيروس و غير محمي بكلمة سر ، وإلا لن تجد المساعدة من قبل الأعضاء. التوجيه التاسع : متابعة صاحب الموضوع لموضوعه والتفاعل معه ، فلا يعقل أن يطرح أحدهم موضوع ولا يتابعه إلا بعد مرور وقت طويل ، فهذا يعد من اللامبالاة الغير مرغوب فيها ، والتي تنفر الجميع من العضو. التوجيه العاشر : عدم التسجيل في المنتدى بأكثر من حساب ، وأن يكون اسم الظهور باللغة العربية ومعبر عن الاسم الحقيقي أي (تعريب اسم العضو) ، فلا يجوز أن يكون اسم الظهور اسم واحد وفقط بل أن يكون ثنائي على الأقل أو أن يكون اسم ولقب ، ولذا يرجى عدم استخدام الأسماء المستعارة أو الأسماء باللغة الأجنبية ، فاللغة العربية هي هويتنا ولابد من الحافظ عليها. ** يتم تغيير اسم الظهور أو اسم المستخدم من خلال إعدادات الحساب ثم التبويب اسم المستخدم ، قم بتغيير الاسم ثم انقر كلمة حفظ التوجيه الحادي عشر : عدم طرح أكثر من موضوع لنفس الطلب من نفس العضو ، فهذا يعد مخالفة صريحة ، وليعلم العضو الذي يقوم بذلك أن تكرار الموضوع لن يجدي نفعاً في حالة عدم توضيحه للمطلوب. وفي حالة أن قام العضو بذلك عن طريق الخطأ يقوم العضو بالتنويه في الموضوع وطلب حذف الموضوع نظراً لتكراره. التوجيه الثاني عشر : على من يقدم المساعدة أن يكون مثالاً يحتذى به في العطاء والصبر والحلم وكرم الأخلاق وحسن الإجابة ، يجتذب بتلك الصفات عقول الآخرين وأفئدتهم التوجيه الثالث عشر : عند طرح موضوع يفضل أن يكون هناك طلب واحد فقط إذ أن الموضوع الذي تكثر فيه الطلبات ينفر الأعضاء الذين يريدون تقديم يد المساعدة ، وعلى رأي المثل (من يطارد عصفورين يفقدهما) فما بالك لو طاردت أكثر من طلبين أقصد أكثر من عصفورين ، يمكنك أن تتعامل بذكاء بأن تطرح الموضوع بطلب واحد حتى إذا تم على خير قم على الفور بطرح موضع جديد بطلب جديد وهكذا إلى أن يتم الأمر التوجيه الرابع عشر : يرجلا عدم إرسال رسائل خاصة للأعضاء لطلب المساعدة بشكل شخصي ، لأن هذا الأمر يضايق الكثير من الأعضاء ، وتأكد أن العضو إذا كان لديه معلومة أو يستطيع أن يفيد بشيء ووقته يسمح بذلك فلن يتأخر عنك ، يكفي أن تكتب كلمة "للرفع" في موضوعك ، ليشاهده أكبر عدد من الأعضاء. ** كيفية رفع الصور في المشاركات : ******************************* دمتم على طاعة الله

أخي الكريم محمد علي ضع الكود التالي في موديول عادي 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

أخي العزيز أنس دروبي جرب الكود التالي عله يفي بالغرض Private Sub save_pro_Click() Dim C As Range, LR As Long Dim Ctrl As Control For Each Ctrl In Me.Controls If TypeName(Ctrl) = "CheckBox" Then If Ctrl.Value = True Then With Worksheets("4") On Error Resume Next Set C = .Rows(1).Find(What:=Ctrl.Caption, LookAt:=xlWhole) On Error GoTo 0 If Not C Is Nothing Then LR = .Cells(Rows.Count, 1).End(xlUp).Row Intersect(.UsedRange, .Range(.Cells(C.Row, C.Column), .Cells(LR, C.Column))).Copy Worksheets("5").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) End If End With End If End If Next Ctrl Unload Me End Sub تقبل تحياتي

زيادة في اثراء الموضوع هذه المعادلة =SUM(INDIRECT(ADDRESS(8,MATCH($B$6,$A$8:$AO$8,0),1)&":"&SUBSTITUTE(ADDRESS(8,MATCH($B$6,$A$8:$AO$8,0),1),RIGHT(ADDRESS(8,MATCH($B$6,$A$8:$AO$8,0),1),1),"")&27))

أخى الفاضل سليم سلمت يداك أخى محمد هل تقصد هكذا =SUMIFS(OFFSET($D$9;;MATCH(B6;D8:AO8;0)-1;27;1);A9:A35;B3;B9:B35;B4;C9:C35;B5) New Microsoft Excel Worksheet.rar

السلام عليكم و رحمة الله وبركاته جزاكم الله كل خير

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

بسم الله ماشاء الله اسال الله العلى العظيم ان يتقبل منك وان يجعل كل حرف شاركت به فى 8888 ان يمحو عنك سيئة ويجعل لك حسنه اطال الله فى عمرك وبارك فيك

تكرم حبيبي ربنا يجازيك كل خير ولك بمثل ما دعوت به كنت عايز ابارك لك على المشاركة رقم 8888 ولكن يشاء القدر ان مشاركتك 8889 تكون لي وبوظت ليك الرقم ههه تقبل تحياتي

لا أعلم اذا كان هذا المطلوب بالفعل Salim Work.rar

تفضل اخي ابو البراء وجدت لك كود اخر اجمل ويعتمد علي استخدام ال IDs جرب وشوف قوائم بطريقة افضل add menu yasser.rar

أخي الكريم ابن الملك المتغير MyAr عبارة عن مصفوفة ثنائية الأبعاد ..تم تحديد أبعاد المصفوفة في السطر التالي ReDim Preserve MyAr(1 To ContColmn, 1 To ii) بعد اسم المتغير وما بين الأقواس هي أبعاد المصفوفة .. البعد الأول ثم فاصلة ثم البعد الثاني وتعتمد على المتغيرات ContColmn و iii ...

السلام عليكم اقدم لكم في هذا الموضوع قناة على اليوتيوب خاصة بالاكسيل تحتوى القناة على اكثر من 160000 (مائة وستون الف) درس فيديو مدعمة بملفات للشرح حتى لحظة كتابة الموضوع وبعض الدروس اكثر من ساعة للدرس انا استفدت من هذه القناة كثيرا جدا ارجو ان تستفيدوا منها https://www.youtube.com/user/ExcelIsFun/videos

وعليكم السلام ورحمة الله وبركاته أخي الحبيب عبد العزيز افتقدناك لفترة ..عسى أن يكون غيابك عن إخوانك خير إن شاء الله الحمد لله أن نال الملف إعجابك .. بالنسبة لسؤالك فيما يخص تسلسل الصور .. يتم حفظ الصور في العمود V حسب الكود الخاص بحفظ الصورة في ورقة العمل ... وهناك دالة معرفة في الموديول من خلالها يمكن معرفة أول صف فارغ ليس به صور فيقوم الكود في المرة الثانية بإدراج الصورة تحت آخر صورة تم إدراجها من قبل في العمود V فقط .. تقبل وافر تقديري واحترامي

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

السلام عليكم أخي نبيل تفضل: . ولكن الكود لن يعمل اذا رقم اللغة لم يكن صحيحا في الكود وهذا هو الكود: Option Compare Database Private Declare Function ActivateKeyboardLayout Lib _ "user32.dll" (ByVal myLanguage As Long, Flag As Boolean) As Long Private Const Ar = 5121 'Arabic United Arab Emirates keyboard language layout, Oman 8193 Private Const Fr = 1036 'Français(united states)keyboard language layout Private Const En = 1033 'US Private Sub cmd_Change_Language_Click() 'go back to the same field we were in, but to the end of it Dim ctl As Access.Control Set ctl = Screen.PreviousControl 'the last control we were on ctl.SetFocus 'set the focus back to it ctl.SelStart = Len(ctl.Text) 'go to the end of the field, so that we can continue writing If Me.cmd_Change_Language.Caption = "Arabic" Then Me.cmd_Change_Language.Caption = "French" Call ActivateKeyboardLayout(Ar, 0) ElseIf Me.cmd_Change_Language.Caption = "French" Then Me.cmd_Change_Language.Caption = "Arabic" Call ActivateKeyboardLayout(Fr, 0) End If End Sub Private Sub Form_Load() 'start with Arabic Call ActivateKeyboardLayout(Ar, 0) End Sub وهذا للقائمة المنسدلة Private Sub textlog_AfterUpdate() If Me.textlog.Value = "Arabic" Then Call ActivateKeyboardLayout(Ar, 0) ElseIf Me.textlog.Value = "French" Then Call ActivateKeyboardLayout(Fr, 0) End If End Sub . جعفر 283.Database changer.accdb.zip

السّلام عليكم و رحمة الله و بركاته أخي الكريم .. هذا حل بطريقة أخرى .. ليس الحل الأمثل .. لكن أفضل من البطالة .. شغّل نفسك به قليلاً ريثما يتدخّل أحد الإخوة الأفاضل .. تقوم بجلب رابط الصورة ثم يتم ترحيل هذا الرابط .. و من خلال الرابط على الشيت يمكنك معاينه الصّورة إدراج الصورة.rar

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

السّلام عليكم و رحمة الله و بركاته و هذه أخي الكريم إحدى روائع أخانا العزيز الغالي ياسر خليل أبو البراء جزاه الله خيرًا و زادها بميزان حسناته التاريخ الميلادي و الهجري.rar

السلام عليكم جمع خلايا حسب اخر ثلاث ارقام.rar

أخي الكريم عبد العزيز محمد إليك الملف المرفق لأخونا أبا الحسن والحسين فيه الطلب الأول بالنسبة للطلب الثاني توجد الأداة Frame تقوم بعمل إطار يمكنك وضع الأدوات بداخلها أرجو أن يفي الملف المرفق بالغرض Gregorian Hijri Dates UserForm.rar

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

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

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

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

أخي الكريم محمد علي إذا أردت المساعدة عليك تسهيل الأمر على إخوانك المرفق غير معبر عن الطلب .. قم بإرفاق ملف يخص طلبك فقط واحذف أية أكواد أخرى كما قم بحذف الفورم الغير مستخدم وركز على الفورم المطلوب فقط ، لتيسير الإطلاع على الملف من قبل إخوانك .. كما أنني لم ألاحظ وجود Image على الفورم .. ما هو الفورم المطلوب العمل عليه ؟؟ أفضل إرفاق الملف مرة أخرى بعد إجراء عملية تنقيح بحيث يكون الملف يخص الطلب في الموضوع المخصص له فقط تقبل تحياتي

السلام عليكم جميع الاخوان فيهم الخير لكن مشركة الاخوان متميزة جدا شكرا لكم

جزاك الله خيرا اخى محمد

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

الحمد لله أن تم المطلوب على خير أخي الحبيب محمد الزريعي بالفعل لا تقم بالإعلان عن المتغيرين det1 و det2 من النوع تاريخ فقد ذكرت لك أنه تم تحويلهما ليكونا كرقم متسلسل وليس تاريخ .. يفضل الإعلان عنهما من النوع Variant عموماً الحمد لله أن عرفت موضع المشكلة وتم حلها بفضل الله وحده تقبل تحياتي

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

اخى الكريم هل هذا ما تريد نقل بيانات من خلية الي خلية اخري.rar

ارسال ملفك سيجعل الامور اوضح... مثلا هذا ما تريده ؟؟؟ 1111.rar

تفضل عملت لك طريقتين: الاولى باستخدام الجدول المؤقت tbl_Temp ، والطريقة الثانية عن طريق الكود ووحدة نمطية: . الجزء الاول من الكود لطريقة الجدول المؤقت ، والطريقة الثانية للكود: Function Sort_It() Dim rst As DAO.Recordset Dim rstT As DAO.Recordset 'clear tbl_Temp CurrentDb.Execute ("Delete * From tbl_Temp") 'DoCmd.RunSQL ("Delete * From tbl_Temp") Set rst = CurrentDb.OpenRecordset("Select * From [درجات] Where [Auto_ID]=" & Me.Auto_ID) Set rstT = CurrentDb.OpenRecordset("Select * From tbl_Temp") For ii = 1 To rst.Fields.Count - 1 'MsgBox rst(ii).Name & vbCrLf & rst(ii) rstT.AddNew rstT!iNumber = rst(ii) rstT!iField = rst(ii).Name rstT.Update Next ii 'DoCmd.OpenQuery "qry_Sort_it" Set rst = CurrentDb.OpenRecordset("Select * From tbl_Temp Order By iNumber Desc") rst.MoveLast: rst.MoveFirst Me.L1 = rst!iNumber & vbCrLf & rst!iField rst.MoveNext Me.L2 = rst!iNumber & vbCrLf & rst!iField rst.MoveNext Me.L3 = rst!iNumber & vbCrLf & rst!iField rst.Close: Set rst = Nothing rstT.Close: Set rstT = Nothing End Function Private Sub Form_Current() Call Sort_It Me.L11 = "" Me.L22 = "" Me.L33 = "" Call cmd_Sort_Click End Sub Private Sub cmd_Sort_Click() Dim rst As DAO.Recordset Dim InputArray() As Variant Set rst = CurrentDb.OpenRecordset("Select * From [درجات] Where [Auto_ID]=" & Me.Auto_ID) ReDim InputArray(rst.Fields.Count - 1) 'make the array For ii = 1 To rst.Fields.Count - 1 'MsgBox rst(ii).Name & vbCrLf & rst(ii) InputArray(ii) = rst(ii) Next ii 'call the sorting array Call QSortInPlace(InputArray, , , True) 'display the numbers For ii = 0 To rst.Fields.Count - 2 'then sorted numbers For jj = 0 To rst.Fields.Count - 2 'match the numbers, then display its field name If InputArray(ii) = rst(jj) Then 'MsgBox InputArray(ii) & vbCrLf & rst(jj).Name 'don't repeat the same field name If InStr(Me.L11, rst(jj).Name) > 0 Or InStr(Me.L22, rst(jj).Name) > 0 Then GoTo 2 If Len(Me.L11 & "") = 0 Then Me.L11 = InputArray(ii) & vbCrLf & rst(jj).Name ElseIf Len(Me.L22 & "") = 0 Then Me.L22 = InputArray(ii) & vbCrLf & rst(jj).Name ElseIf Len(Me.L33 & "") = 0 Then Me.L33 = InputArray(ii) & vbCrLf & rst(jj).Name End If End If 2: Next jj Next ii End Sub . واما الوحدة النمطية التي استخدمتها للفرز: Option Compare Database Public Function QSortInPlace( _ ByRef InputArray As Variant, _ Optional ByVal LB As Long = -1&, _ Optional ByVal UB As Long = -1&, _ Optional ByVal Descending As Boolean = False, _ Optional ByVal CompareMode As VbCompareMethod = vbTextCompare, _ Optional ByVal NoAlerts As Boolean = False) As Boolean ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' QSortInPlace ' ' This function sorts the array InputArray in place -- this is, the original array in the ' calling procedure is sorted. It will work with either string data or numeric data. ' It need not sort the entire array. You can sort only part of the array by setting the LB and ' UB parameters to the first (LB) and last (UB) element indexes that you want to sort. ' LB and UB are optional parameters. If omitted LB is set to the LBound of InputArray, and if ' omitted UB is set to the UBound of the InputArray. If you want to sort the entire array, ' omit the LB and UB parameters, or set both to -1, or set LB = LBound(InputArray) and set ' UB to UBound(InputArray). ' ' By default, the sort method is case INSENSTIVE (case doens't matter: "A", "b", "C", "d"). ' To make it case SENSITIVE (case matters: "A" "C" "b" "d"), set the CompareMode argument ' to vbBinaryCompare (=0). If Compare mode is omitted or is any value other than vbBinaryCompare, ' it is assumed to be vbTextCompare and the sorting is done case INSENSITIVE. ' ' The function returns TRUE if the array was successfully sorted or FALSE if an error ' occurred. If an error occurs (e.g., LB > UB), a message box indicating the error is ' displayed. To suppress message boxes, set the NoAlerts parameter to TRUE. ' '''''''''''''''''''''''''''''''''''''' ' MODIFYING THIS CODE: '''''''''''''''''''''''''''''''''''''' ' If you modify this code and you call "Exit Procedure", you MUST decrment the RecursionLevel ' variable. E.g., ' If SomethingThatCausesAnExit Then ' RecursionLevel = RecursionLevel - 1 ' Exit Function ' End If ''''''''''''''''''''''''''''''''''''''' ' ' Note: If you coerce InputArray to a ByVal argument, QSortInPlace will not be ' able to reference the InputArray in the calling procedure and the array will ' not be sorted. ' ' This function uses the following procedures. These are declared as Private procedures ' at the end of this module: ' IsArrayAllocated ' IsSimpleDataType ' IsSimpleNumericType ' QSortCompare ' NumberOfArrayDimensions ' ReverseArrayInPlace ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Temp As Variant Dim Buffer As Variant Dim CurLow As Long Dim CurHigh As Long Dim CurMidpoint As Long Dim Ndx As Long Dim pCompareMode As VbCompareMethod ''''''''''''''''''''''''' ' Set the default result. ''''''''''''''''''''''''' QSortInPlace = False '''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' This variable is used to determine the level ' of recursion (the function calling itself). ' RecursionLevel is incremented when this procedure ' is called, either initially by a calling procedure ' or recursively by itself. The variable is decremented ' when the procedure exits. We do the input parameter ' validation only when RecursionLevel is 1 (when ' the function is called by another function, not ' when it is called recursively). '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Static RecursionLevel As Long '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Keep track of the recursion level -- that is, how many ' times the procedure has called itself. ' Carry out the validation routines only when this ' procedure is first called. Don't run the ' validations on a recursive call to the ' procedure. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' RecursionLevel = RecursionLevel + 1 If RecursionLevel = 1 Then '''''''''''''''''''''''''''''''''' ' Ensure InputArray is an array. '''''''''''''''''''''''''''''''''' If IsArray(InputArray) = False Then If NoAlerts = False Then MsgBox "The InputArray parameter is not an array." End If ''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' InputArray is not an array. Exit with a False result. ''''''''''''''''''''''''''''''''''''''''''''''''''''''' RecursionLevel = RecursionLevel - 1 Exit Function End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Test LB and UB. If < 0 then set to LBound and UBound ' of the InputArray. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If LB < 0 Then LB = LBound(InputArray) End If If UB < 0 Then UB = UBound(InputArray) End If Select Case NumberOfArrayDimensions(InputArray) Case 0 '''''''''''''''''''''''''''''''''''''''''' ' Zero dimensions indicates an unallocated ' dynamic array. '''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The InputArray is an empty, unallocated array." End If RecursionLevel = RecursionLevel - 1 Exit Function Case 1 '''''''''''''''''''''''''''''''''''''''''' ' We sort ONLY single dimensional arrays. '''''''''''''''''''''''''''''''''''''''''' Case Else '''''''''''''''''''''''''''''''''''''''''' ' We sort ONLY single dimensional arrays. '''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The InputArray is multi-dimensional." & _ "QSortInPlace works only on single-dimensional arrays." End If RecursionLevel = RecursionLevel - 1 Exit Function End Select ''''''''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that InputArray is an array of simple data ' types, not other arrays or objects. This tests ' the data type of only the first element of ' InputArray. If InputArray is an array of Variants, ' subsequent data types may not be simple data types ' (e.g., they may be objects or other arrays), and ' this may cause QSortInPlace to fail on the StrComp ' operation. ''''''''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then If NoAlerts = False Then MsgBox "InputArray is not an array of simple data types." RecursionLevel = RecursionLevel - 1 Exit Function End If End If '''''''''''''''''''''''''''''''''''''''''''''''''''' ' ensure that the LB parameter is valid. '''''''''''''''''''''''''''''''''''''''''''''''''''' Select Case LB Case Is < LBound(InputArray) If NoAlerts = False Then MsgBox "The LB lower bound parameter is less than the LBound of the InputArray" End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is > UBound(InputArray) If NoAlerts = False Then MsgBox "The LB lower bound parameter is greater than the UBound of the InputArray" End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is > UB If NoAlerts = False Then MsgBox "The LB lower bound parameter is greater than the UB upper bound parameter." End If RecursionLevel = RecursionLevel - 1 Exit Function End Select '''''''''''''''''''''''''''''''''''''''''''''''''''' ' ensure the UB parameter is valid. '''''''''''''''''''''''''''''''''''''''''''''''''''' Select Case UB Case Is > UBound(InputArray) If NoAlerts = False Then MsgBox "The UB upper bound parameter is greater than the upper bound of the InputArray." End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is < LBound(InputArray) If NoAlerts = False Then MsgBox "The UB upper bound parameter is less than the lower bound of the InputArray." End If RecursionLevel = RecursionLevel - 1 Exit Function Case Is < LB If NoAlerts = False Then MsgBox "the UB upper bound parameter is less than the LB lower bound parameter." End If RecursionLevel = RecursionLevel - 1 Exit Function End Select '''''''''''''''''''''''''''''''''''''''''''''''''''''' ' if UB = LB, we have nothing to sort, so get out. '''''''''''''''''''''''''''''''''''''''''''''''''''''' If UB = LB Then QSortInPlace = True RecursionLevel = RecursionLevel - 1 Exit Function End If End If ' RecursionLevel = 1 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that CompareMode is either vbBinaryCompare or ' vbTextCompare. If it is neither, default to vbTextCompare. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If (CompareMode = vbBinaryCompare) Or (CompareMode = vbTextCompare) Then pCompareMode = CompareMode Else pCompareMode = vbTextCompare End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Begin the actual sorting process. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' CurLow = LB CurHigh = UB If LB = 0 Then CurMidpoint = ((LB + UB) \ 2) + 1 Else CurMidpoint = (LB + UB) \ 2 ' note integer division (\) here End If Temp = InputArray(CurMidpoint) Do While (CurLow <= CurHigh) Do While QSortCompare(V1:=InputArray(CurLow), V2:=Temp, CompareMode:=pCompareMode) < 0 CurLow = CurLow + 1 If CurLow = UB Then Exit Do End If Loop Do While QSortCompare(V1:=Temp, V2:=InputArray(CurHigh), CompareMode:=pCompareMode) < 0 CurHigh = CurHigh - 1 If CurHigh = LB Then Exit Do End If Loop If (CurLow <= CurHigh) Then Buffer = InputArray(CurLow) InputArray(CurLow) = InputArray(CurHigh) InputArray(CurHigh) = Buffer CurLow = CurLow + 1 CurHigh = CurHigh - 1 End If Loop If LB < CurHigh Then QSortInPlace InputArray:=InputArray, LB:=LB, UB:=CurHigh, _ Descending:=Descending, CompareMode:=pCompareMode, NoAlerts:=True End If If CurLow < UB Then QSortInPlace InputArray:=InputArray, LB:=CurLow, UB:=UB, _ Descending:=Descending, CompareMode:=pCompareMode, NoAlerts:=True End If ''''''''''''''''''''''''''''''''''''' ' If Descending is True, reverse the ' order of the array, but only if the ' recursion level is 1. ''''''''''''''''''''''''''''''''''''' If Descending = True Then If RecursionLevel = 1 Then ReverseArrayInPlace2 InputArray, LB, UB End If End If RecursionLevel = RecursionLevel - 1 QSortInPlace = True End Function Public Function QSortCompare(V1 As Variant, V2 As Variant, _ Optional CompareMode As VbCompareMethod = vbTextCompare) As Long ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' QSortCompare ' This function is used in QSortInPlace to compare two elements. If ' V1 AND V2 are both numeric data types (integer, long, single, double) ' they are converted to Doubles and compared. If V1 and V2 are BOTH strings ' that contain numeric data, they are converted to Doubles and compared. ' If either V1 or V2 is a string and does NOT contain numeric data, both ' V1 and V2 are converted to Strings and compared with StrComp. ' ' The result is -1 if V1 < V2, ' 0 if V1 = V2 ' 1 if V1 > V2 ' For text comparisons, case sensitivity is controlled by CompareMode. ' If this is vbBinaryCompare, the result is case SENSITIVE. If this ' is omitted or any other value, the result is case INSENSITIVE. ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim D1 As Double Dim D2 As Double Dim S1 As String Dim S2 As String Dim Compare As VbCompareMethod '''''''''''''''''''''''''''''''''''''''''''''''' ' Test CompareMode. Any value other than ' vbBinaryCompare will default to vbTextCompare. '''''''''''''''''''''''''''''''''''''''''''''''' If CompareMode = vbBinaryCompare Or CompareMode = vbTextCompare Then Compare = CompareMode Else Compare = vbTextCompare End If ''''''''''''''''''''''''''''''''''''''''''''''' ' If either V1 or V2 is either an array or ' an Object, raise a error 13 - Type Mismatch. ''''''''''''''''''''''''''''''''''''''''''''''' If IsArray(V1) = True Or IsArray(V2) = True Then Err.Raise 13 Exit Function End If If IsObject(V1) = True Or IsObject(V2) = True Then Err.Raise 13 Exit Function End If If IsSimpleNumericType(V1) = True Then If IsSimpleNumericType(V2) = True Then ''''''''''''''''''''''''''''''''''''' ' If BOTH V1 and V2 are numeric data ' types, then convert to Doubles and ' do an arithmetic compare and ' return the result. ''''''''''''''''''''''''''''''''''''' D1 = CDbl(V1) D2 = CDbl(V2) If D1 = D2 Then QSortCompare = 0 Exit Function End If If D1 < D2 Then QSortCompare = -1 Exit Function End If If D1 > D2 Then QSortCompare = 1 Exit Function End If End If End If '''''''''''''''''''''''''''''''''''''''''''' ' Either V1 or V2 was not numeric data type. ' Test whether BOTH V1 AND V2 are numeric ' strings. If BOTH are numeric, convert to ' Doubles and do a arithmetic comparison. '''''''''''''''''''''''''''''''''''''''''''' If IsNumeric(V1) = True And IsNumeric(V2) = True Then D1 = CDbl(V1) D2 = CDbl(V2) If D1 = D2 Then QSortCompare = 0 Exit Function End If If D1 < D2 Then QSortCompare = -1 Exit Function End If If D1 > D2 Then QSortCompare = 1 Exit Function End If End If '''''''''''''''''''''''''''''''''''''''''''''' ' Either or both V1 and V2 was not numeric ' string. In this case, convert to Strings ' and use StrComp to compare. '''''''''''''''''''''''''''''''''''''''''''''' S1 = CStr(V1) S2 = CStr(V2) QSortCompare = StrComp(S1, S2, Compare) End Function Public Function NumberOfArrayDimensions(Arr As Variant) As Integer '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' NumberOfArrayDimensions ' This function returns the number of dimensions of an array. An unallocated dynamic array ' has 0 dimensions. This condition can also be tested with IsArrayEmpty. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Ndx As Integer Dim Res As Integer On Error Resume Next ' Loop, increasing the dimension index Ndx, until an error occurs. ' An error will occur when Ndx exceeds the number of dimension ' in the array. Return Ndx - 1. Do Ndx = Ndx + 1 Res = UBound(Arr, Ndx) Loop Until Err.Number <> 0 NumberOfArrayDimensions = Ndx - 1 End Function Public Function ReverseArrayInPlace(InputArray As Variant, _ Optional NoAlerts As Boolean = False) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ReverseArrayInPlace ' This procedure reverses the order of an array in place -- this is, the array variable ' in the calling procedure is sorted. An error will occur if InputArray is not an array, 'if it is an empty, unallocated array, or if the number of dimensions is not 1. ' ' NOTE: Before calling the ReverseArrayInPlace procedure, consider if your needs can ' be met by simply reading the existing array in reverse order (Step -1). If so, you can save ' the overhead added to your application by calling this function. ' ' The function returns TRUE if the array was successfully reversed, or FALSE if ' an error occurred. ' ' If an error occurred, a message box is displayed indicating the error. To suppress ' the message box and simply return FALSE, set the NoAlerts parameter to TRUE. ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Temp As Variant Dim Ndx As Long Dim Ndx2 As Long Dim OrigN As Long Dim NewN As Long Dim NewArr() As Variant '''''''''''''''''''''''''''''''' ' Set the default return value. '''''''''''''''''''''''''''''''' ReverseArrayInPlace = False ''''''''''''''''''''''''''''''''' ' Ensure we have an array ''''''''''''''''''''''''''''''''' If IsArray(InputArray) = False Then If NoAlerts = False Then MsgBox "The InputArray parameter is not an array." End If Exit Function End If '''''''''''''''''''''''''''''''''''''' ' Test the number of dimensions of the ' InputArray. If 0, we have an empty, ' unallocated array. Get out with ' an error message. If greater than ' one, we have a multi-dimensional ' array, which is not allowed. Only ' an allocated 1-dimensional array is ' allowed. '''''''''''''''''''''''''''''''''''''' Select Case NumberOfArrayDimensions(InputArray) Case 0 ''''''''''''''''''''''''''''''''''''''''''' ' Zero dimensions indicates an unallocated ' dynamic array. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array is an empty, unallocated array." End If Exit Function Case 1 ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' Case Else ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _ "on single-dimensional arrays." End If Exit Function End Select ''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that we have only simple data types, ' not an array of objects or arrays. ''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then If NoAlerts = False Then MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _ "ReverseArrayInPlace can reverse only arrays of simple data types." Exit Function End If End If ReDim NewArr(LBound(InputArray) To UBound(InputArray)) NewN = UBound(NewArr) For OrigN = LBound(InputArray) To UBound(InputArray) NewArr(NewN) = InputArray(OrigN) NewN = NewN - 1 Next OrigN For NewN = LBound(NewArr) To UBound(NewArr) InputArray(NewN) = NewArr(NewN) Next NewN ReverseArrayInPlace = True End Function Public Function ReverseArrayInPlace2(InputArray As Variant, _ Optional LB As Long = -1, Optional UB As Long = -1, _ Optional NoAlerts As Boolean = False) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ReverseArrayInPlace2 ' This reverses the order of elements in InputArray. To reverse the entire array, omit or ' set to less than 0 the LB and UB parameters. To reverse only part of tbe array, set LB and/or ' UB to the LBound and UBound of the sub array to be reversed. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim N As Long Dim Temp As Variant Dim Ndx As Long Dim Ndx2 As Long Dim OrigN As Long Dim NewN As Long Dim NewArr() As Variant '''''''''''''''''''''''''''''''' ' Set the default return value. '''''''''''''''''''''''''''''''' ReverseArrayInPlace2 = False ''''''''''''''''''''''''''''''''' ' Ensure we have an array ''''''''''''''''''''''''''''''''' If IsArray(InputArray) = False Then If NoAlerts = False Then MsgBox "The InputArray parameter is not an array." End If Exit Function End If '''''''''''''''''''''''''''''''''''''' ' Test the number of dimensions of the ' InputArray. If 0, we have an empty, ' unallocated array. Get out with ' an error message. If greater than ' one, we have a multi-dimensional ' array, which is not allowed. Only ' an allocated 1-dimensional array is ' allowed. '''''''''''''''''''''''''''''''''''''' Select Case NumberOfArrayDimensions(InputArray) Case 0 ''''''''''''''''''''''''''''''''''''''''''' ' Zero dimensions indicates an unallocated ' dynamic array. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array is an empty, unallocated array." End If Exit Function Case 1 ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' Case Else ''''''''''''''''''''''''''''''''''''''''''' ' We can reverse ONLY a single dimensional ' arrray. ''''''''''''''''''''''''''''''''''''''''''' If NoAlerts = False Then MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _ "on single-dimensional arrays." End If Exit Function End Select ''''''''''''''''''''''''''''''''''''''''''''' ' Ensure that we have only simple data types, ' not an array of objects or arrays. ''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then If NoAlerts = False Then MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _ "ReverseArrayInPlace can reverse only arrays of simple data types." Exit Function End If End If If LB < 0 Then LB = LBound(InputArray) End If If UB < 0 Then UB = UBound(InputArray) End If For N = LB To (LB + ((UB - LB - 1) \ 2)) Temp = InputArray(N) InputArray(N) = InputArray(UB - (N - LB)) InputArray(UB - (N - LB)) = Temp Next N ReverseArrayInPlace2 = True End Function Public Function IsSimpleNumericType(V As Variant) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' IsSimpleNumericType ' This returns TRUE if V is one of the following data types: ' vbBoolean ' vbByte ' vbCurrency ' vbDate ' vbDecimal ' vbDouble ' vbInteger ' vbLong ' vbSingle ' vbVariant if it contains a numeric value ' It returns FALSE for any other data type, including any array ' or vbEmpty. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If IsSimpleDataType(V) = True Then Select Case VarType(V) Case vbBoolean, _ vbByte, _ vbCurrency, _ vbDate, _ vbDecimal, _ vbDouble, _ vbInteger, _ vbLong, _ vbSingle IsSimpleNumericType = True Case vbVariant If IsNumeric(V) = True Then IsSimpleNumericType = True Else IsSimpleNumericType = False End If Case Else IsSimpleNumericType = False End Select Else IsSimpleNumericType = False End If End Function Public Function IsSimpleDataType(V As Variant) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' IsSimpleDataType ' This function returns TRUE if V is one of the following ' variable types (as returned by the VarType function: ' vbBoolean ' vbByte ' vbCurrency ' vbDate ' vbDecimal ' vbDouble ' vbEmpty ' vbError ' vbInteger ' vbLong ' vbNull ' vbSingle ' vbString ' vbVariant ' ' It returns FALSE if V is any one of the following variable ' types: ' vbArray ' vbDataObject ' vbObject ' vbUserDefinedType ' or if it is an array of any type. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Test if V is an array. We can't just use VarType(V) = vbArray ' because the VarType of an array is vbArray + VarType(type ' of array element). E.g, the VarType of an Array of Longs is ' 8195 = vbArray + vbLong. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If IsArray(V) = True Then IsSimpleDataType = False Exit Function End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' We must also explicitly check whether V is an object, rather ' relying on VarType(V) to equal vbObject. The reason is that ' if V is an object and that object has a default proprety, VarType ' returns the data type of the default property. For example, if ' V is an Excel.Range object pointing to cell A1, and A1 contains ' 12345, VarType(V) would return vbDouble, the since Value is ' the default property of an Excel.Range object and the default ' numeric type of Value in Excel is Double. Thus, in order to ' prevent this type of behavior with default properties, we test ' IsObject(V) to see if V is an object. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If IsObject(V) = True Then IsSimpleDataType = False Exit Function End If ''''''''''''''''''''''''''''''''''''' ' Test the value returned by VarType. ''''''''''''''''''''''''''''''''''''' Select Case VarType(V) Case vbArray, vbDataObject, vbObject, vbUserDefinedType ''''''''''''''''''''''' ' not simple data types ''''''''''''''''''''''' IsSimpleDataType = False Case Else '''''''''''''''''''''''''''''''''''' ' otherwise it is a simple data type '''''''''''''''''''''''''''''''''''' IsSimpleDataType = True End Select End Function Public Function IsArrayAllocated(Arr As Variant) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' IsArrayAllocated ' Returns TRUE if the array is allocated (either a static array or a dynamic array that has been ' sized with Redim) or FALSE if the array has not been allocated (a dynamic that has not yet ' been sized with Redim, or a dynamic array that has been Erased). '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim N As Long ''''''''''''''''''''''''''''''''''''''''''''''''''' ' If Arr is not an array, return FALSE and get out. ''''''''''''''''''''''''''''''''''''''''''''''''''' If IsArray(Arr) = False Then IsArrayAllocated = False Exit Function End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Try to get the UBound of the array. If the array has not been allocated, ' an error will occur. Test Err.Number to see if an error occured. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next N = UBound(Arr, 1) If Err.Number = 0 Then ''''''''''''''''''''''''''''''''''''' ' No error. Array has been allocated. ''''''''''''''''''''''''''''''''''''' IsArrayAllocated = True Else ''''''''''''''''''''''''''''''''''''' ' Error. Unallocated array. ''''''''''''''''''''''''''''''''''''' IsArrayAllocated = False End If End Function جعفر 281.1جديد.mdb.zip

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

جرب هذا الملف لا اعرف اذا كان المطلوب DATA.rar

لا يوجد لدي خطأ في الناتج اطلع على الصورة التالية

بارك الله فيك أخي الفاضل محمد عادل على موضوعاتك القيمة والمفيدة للجميع وأعتقد أن معظمنا في الموضوعات يقوم بالنقل من مصادر مختلفة ولكن لي رأي اسمحوا لي به .. إذا أردت دراسة موضوع معين قم بدراسته جيداً أي قم بهضم الموضوع بشكل جيد من كافة النواحي ثم قدم الموضوع بأسلوبك وبملف مرفق يخصك فيه تطبيق للموضوع كما يجب أن يكون هناك خطوات مشروحة لما تم عمله ليظهر الملف بهذا الشكل أي خطوات العمل التي يجب أن تكون موجودة ليسير على دربها من أراد التعلم .. لأن الكثيرين يقومون بتحميل الملف ولا يستفيد منه إلا ذوي الخبرة فقط لأنهم يقومون بعملية التنقيب .. اجعل الموضوع كخريطة واضحة المعالم ليسير على دربها مريدي التعلم تقبل وافر تقديري واحترامي

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

حياك الله اخي حامد لم افهم في اصورة تقصد ... وحبذا ترفق ما توصلت اليه بالتوفيق

استاذى الفاضل هل بالامكان تصدير هذه التقارير الى الوور والاكسيل ؟ هل بالامكان عمل حفظ لهذا التقرير الناتج ؟ _________________________- عمل اكثر من رائع وسوف نستفيد منه كثيراا ___________________________ اتمنى رفع صور الشرح فى ملف مضغوظ رجاء لو تكرمت مع الشرح الكتابي فى ملف نصى او جمع الصور والشرح الكتابي فى ملف بي دى اف جعله الله فى ميزان حسناتك

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