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

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

شرح الكود Sub RoundedRectangle3_Click() ' الاعلان عن متغير من نوع لونج يشير الى اخر صف به بيانات Dim last As Long 'الاعلان عن متغير من نوع لونج يشير الى كل خطوة لوضع التذييل لكل 30 طالب لكل صفحة Dim y As Long '' اول صف سيوضع فيه التذييل y = 40 'لايقاف الحساب التلقائي لعلاج موضوع بطئ عمل الكود اذا كان البطئ من كثرة معادلات المصنف Application.Calculation = xlManual 'حلقة تكرارية تبدأ ب (دو)وتنتهي ب (لووب)وهي لتكرار التذييل حتى ان نصل لاخر صفحه بها بيانات Do 'لمنع اهتزاز الشاشه Application.ScreenUpdating = False 'تعريف المتغير الخاص باخر صف به بيانات last = Sheets("ناجح").Range("a10000").End(xlUp).Row 'هنا نضع شرط اذا كان المتغير واي اكبر من او يساوي اخر صف به بيانات فيخرج الى خارج الحلقة التكرارية الى السطر الموجود به الصفر 'وقمنا بانقاص -36 لانه قمنا باضافتها بالاسفل ولكي نقارن بين المتغير واي واخر صف يجب طرح 36 من الواي او اضافتهم الى لاست If y - 36 >= last Then GoTo 0 ' نسخ الكعب المراد وضعه في صفحة الطلاب Sheets("كعب الشيت").Rows("2:7").Copy ' وضع الكعب بعد كل 30 طالب وازاحة الباقين للاسفل حتى ينتهي من كل البيانات Sheets("ناجح").Rows(y).Insert Shift:=xlDown 'لايقاف خاصيه القص والنسخ Application.CutCopyMode = False ' هنا نقوم باضافة 36 للمتغير وهي قيمة ال30 طاللب بالاضافة لهم الكعب 6 y = y + 36 ' هنا لوووووب بتقولنا نروح للــ دوووو عشان نعيد الكود تاني حتى يتحقق الشرط السابق من الكود Loop 'هنا بعد تحقق الشرط نجد ان حركة الكود تخرج الى الرقم صفر ' ' لاعاده تحديث الشاشه 0 Application.ScreenUpdating = True 'اعادة الحساب التلقائي Application.Calculation = xlAutomatic 'رسالة تفيد انتهاءالعملية MsgBox "تم بحمد لله" End Sub الاخت الكريمة هذا كود لوضع تذييل لكل صفحة بدلا من التذييل المحدود بالبرنامج اذا صعب تطبيقه ارفقى ملف يوضح البيانات وارفقى شكل التذييل المراد تحت احد الصفحات بالشيت الموضوع ليس مكرر اخي الكريم فقط الطلب متشابه بهذ الموضوع تقبلو تحياتي

غير المعادلةفي الخلية E7 الى التالية و اسحب نزولاُ =DATEDIF(D7,$E$2,"y")

تفضل الحل البطاقة المدرسية.rar

ولنا لقاء مع موضوع اخر وان شاء الله يكون به فائده لكم اخوانى الكرام شرح بروتوكول SMTP وكود لإرسال البريد بدوت نت منقول للفائده وبه رابط النقل تقبلوا تحياتى اخوكم احمد شرح بروتوكول SMTP وكود لإرسال البريد بدوت نتsmtp.zip

' 'هذا الكود للمحترم ياسر العربي Sub RoundedRectangle3_Click() Dim last As Long Dim y As Long '' اول صف سيوضع فيه التذييل y = 40 Do ' ' لمنع اهتزاز الشاشه Application.ScreenUpdating = False last = Sheets("ناجح").Range("a10000").End(xlUp).Row If y - 36 >= last Then GoTo 0 ' ' اسم شيت المصدر الذي سيتم حشر الديباجخ فيه Sheets("كعب الشيت").Rows("2:7").Copy ' ' اسم شيت الديباجه التى نريد وضعها في الشيت المصدر Sheets("ناجح").Rows(y).Insert Shift:=xlDown ' 'لايقاف خاصيه القص والنسخ Application.CutCopyMode = False ' ' y = y + 36 Loop ' ' لاعاده تحديث الشاشه 0 Application.ScreenUpdating = True MsgBox "تم بحمد لله" End Sub ' ' ' ' ' ' ' ' ' ' ' ' ' ' الاستاذ الكريم ياسر العربي وضغت شرح لبعض الجمل لكودك الرائع ليكون مرجعا سهلا للاخوه ارجو ان تكمل الشرح للجمل التي لم استطع شرحها

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

السلام عليكم ورحمة الله وبركاته أحبائى فى الله أقدم لكم اليوم كود يوضع فى حدث الشيت المراد فك حمايته يقوم بإلغاء الحماية عن الشيت Sub PasswordBreaker() 'Breaks worksheet password protection. Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable password is " & Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub

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

'كود معاينة طباعة Sub printpreview() ActiveWindow.SelectedSheets.printpreview End Sub الصفحات محميه نرجو فكها او ماهو الرقم السري

ملفك يا استاذ ايمن به جهد ملحوظ بارك الله فيك وهذا كود موجود بداخله من الروائع ليستفيد منه الجميع والدعاء الطيب موصول لصاحبه Sub printpreview1() 'كود معاينة طباعة مطاطي Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).printpreview End Sub Sub print_2() 'كود طباعة مطاطي Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).PrintOut End Sub

تفضل اخي الكريم ضع اي بيانات وهميه وجرب Book2.rar

ملحوظه سليمه الكود يضع تذييلات اكثر من المطلوب

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

بالفعل اخي الكريم هو يذهب الى اخر صف به بيانات لا يغرك الرقم10000 هو بمثابة انك واقف على الخلية a10000 وقمت بالضغط على زر end ثم سهم الى اعلى ستجد ان التحديد ذهب الى اخر صف به بيانات والبطئ ليس من الكود البطئ من معادلات المصنف نفسه وقمت بوضع خطوة لتخفيف الكود ولو مش عجبك دي اكتب دي last = Sheets("ناجح").Cells(Rows.Count, "a").End(xlUp).Row وشكرا

شرح الكود Sub RoundedRectangle3_Click() ' الاعلان عن متغير من نوع لونج يشير الى اخر صف به بيانات Dim last As Long 'الاعلان عن متغير من نوع لونج يشير الى كل خطوة لوضع التذييل لكل 30 طالب لكل صفحة Dim y As Long '' اول صف سيوضع فيه التذييل y = 40 'لايقاف الحساب التلقائي لعلاج موضوع بطئ عمل الكود اذا كان البطئ من كثرة معادلات المصنف Application.Calculation = xlManual 'حلقة تكرارية تبدأ ب (دو)وتنتهي ب (لووب)وهي لتكرار التذييل حتى ان نصل لاخر صفحه بها بيانات Do 'لمنع اهتزاز الشاشه Application.ScreenUpdating = False 'تعريف المتغير الخاص باخر صف به بيانات last = Sheets("ناجح").Range("a10000").End(xlUp).Row 'هنا نضع شرط اذا كان المتغير واي اكبر من او يساوي اخر صف به بيانات فيخرج الى خارج الحلقة التكرارية الى السطر الموجود به الصفر 'وقمنا بانقاص -36 لانه قمنا باضافتها بالاسفل ولكي نقارن بين المتغير واي واخر صف يجب طرح 36 من الواي او اضافتهم الى لاست If y - 36 >= last Then GoTo 0 ' نسخ الكعب المراد وضعه في صفحة الطلاب Sheets("كعب الشيت").Rows("2:7").Copy ' وضع الكعب بعد كل 30 طالب وازاحة الباقين للاسفل حتى ينتهي من كل البيانات Sheets("ناجح").Rows(y).Insert Shift:=xlDown 'لايقاف خاصيه القص والنسخ Application.CutCopyMode = False ' هنا نقوم باضافة 36 للمتغير وهي قيمة ال30 طاللب بالاضافة لهم الكعب 6 y = y + 36 ' هنا لوووووب بتقولنا نروح للــ دوووو عشان نعيد الكود تاني حتى يتحقق الشرط السابق من الكود Loop 'هنا بعد تحقق الشرط نجد ان حركة الكود تخرج الى الرقم صفر ' ' لاعاده تحديث الشاشه 0 Application.ScreenUpdating = True 'اعادة الحساب التلقائي Application.Calculation = xlAutomatic 'رسالة تفيد انتهاءالعملية MsgBox "تم بحمد لله" End Sub

السلام عليكم اخي asdhamdey جزاكم الله خيرا المشكلة في اعدادات الاكسل عندي وتم الحل من خلال الاستاذ ياسر العربي جزاه الله خيرا لاتنفع اي نسخة ارفعها لكم حيث لما بتنزل الملف في الحاسوب الشخصي لكم سياخد الاعدادات الخاصة بالاكسل الذي عندكم ولا تظهر المشكلة وهذا رابط الملف http://www.officena.net/ib/topic/41803-كود-طباعة-بعد-المعاينة/ وهذا رابط ملفي الخاص الذي فيه المشكلة http://www.officena.net/ib/topic/70033-ترحيل-وفتح-ورقة-جديدة-تحمل-اسم-خليه-معينة/ شاكر تعاونكم معي ولكم شكري وتقديري

هات الرابط هات الرابط الاساسي لنجتهد في حل مشكلتك اذا كان تم الحل فارفق النسخه النهائيه ليستفيد غيرك كما استفدت

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

تفضل sumif.rar

تفضل لازالة هذه الرسالة وتفعيل الماكرو ايضا http://www.officena.net/ib/topic/64472-بداية-الطريق-لإنقاذ-الغريق/ تفضل فيديو يشرح الطريقة yasser.rar

وعليكم السلام بالضبط كما تفضلت تكون جملة التحديث هي p_buy * kmyahB ولكن لا حظ وجود حقل مشابه فتكون الجملة الصحيحة هكذا : tbl_Asnaf.p_buy * kmyahB

اخي الكريم لقد قمت بتوسيع نطاق البيانات فوق 16 الف صف ووقت نقل التذييل لم يتعدى ال16 ثانية لجهاز متوسط الامكانيات يعني لو جهاز كويس مش هياخد وقت كبير المهم السبب الاكيد كثرة المعادلات داخل المصنف والتنسيقات والكائنات هعملك طريقة وتجربها Sub RoundedRectangle3_Click() Dim last As Long Dim y As Long y = 40 Application.Calculation = xlManual Do Application.ScreenUpdating = False last = Sheets("ناجح").Range("a10000").End(xlUp).Row If y - 36 >= last Then GoTo 0 Sheets("كعب الشيت").Rows("2:7").Copy Sheets("ناجح").Rows(y).Insert Shift:=xlDown Application.CutCopyMode = False y = y + 36 Loop 0 Application.ScreenUpdating = True Application.Calculation = xlAutomatic MsgBox "تم بحمد الله" End Sub ضع الكود دا وجرب كدا

تفضل صنعت لك ساعة بسيطة باسطر قليلة ومفهومة Private Sub Form_Timer() Label3.Caption = Label3.Caption - 1 If Label3.Caption = 0 Then Label2.Caption = Label2.Caption - 1 Label3.Caption = 60 ElseIf Label2.Caption = 0 Then Label1.Caption = Label1.Caption - 1 Label2.Caption = 60 ElseIf Label1.Caption = 0 Then Me.TimerInterval = 0 End If End Sub بالنسبة للاحداث يمكنك وضعها ذاخل كود المؤقت لاحظ الشرط الاخير وهو حين يصل حقل الدقائق الى صفر يقف المؤقت ElseIf Label1.Caption = 0 Then Me.TimerInterval = 0 يمكنك وضع شروط اخرى مثلا : حين يصل حقل الدقائق الى رقم معين يحدث صوت معين عداد تنازلي.rar

تفضل oficeina.rar

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

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

تفضل مع تعديل طفيف على الكود Dim Untxt Untxt = Nz(DLookup("id", "Qry1"), 0) If Untxt = 0 Then DoCmd.OpenReport "Rep1", acPreview Else MsgBox "يوجد بيانات يجب تصحيحها" Exit Sub End If db1.rar

جرب المرفق اشتغل كان بها لو مشتغلش ونفس الرسالة يبقي تتأكد ان مفيش زرار في لوحة المفاتيح معلق غير كدا تقول نوع الاوفيس عندك ايه وجرب الطريقة دي مؤقتا ندخل للمسار دا C:\Program Files\MS Office\XLSTART نمسح الملف دا GWXL97.XLA نشغل البرنامج تاني Timer.rar

اضف ملف لمعرفة السبب

تفضل عسى ان يكون هوى المطلوب دعواتك ضمان (تم الحفظ تلقائياً).rar

مادة الحاسب الآلي القاضي.rar

جري تغير اعدادات الامان للماكرو

رابط كنترول الصف الرابع والخامس لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-164sjmj1-rar.html رابط كنترول الصف التاني والتالث لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-1642ojx1-rar.html رابط كنترول الصف الاول لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-164sj221-rar.html كلمه السر 1111

تفضل اخي الكريم ناصر اما بخصوص الهيدر فتستطيع عمله عن طريق تثبيت صفوف الهيدر لكل صفحة كما بالصورة 1213123.rar

لقد أضفت نموذج سميته z_2 و أضفت تعديلا صغيرا في التقرير إن شاء الله يكون هو الصواب و الله أعلم sum_time(4).rar

تفضل اخي ايمن 2.rar

هناك كود في حذث الصفحة Private Sub Worksheet_Activate() Cells.EntireRow.Hidden = False End Sub يجب ان توفقه غن العمل وذلك باضافة فاصلة بأوله او ان تحذفه

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

اجعل القيمة الافتراضية = صفر واختر التنسيق Short Time او اجعل القيمة الافتراضية خالية واستخدم الدالة NZ عند اجراء العمليات مثال : nz([text1])+nz([text2])

جرب هذا الملف عندك خيارين:(بخط كبير) قائمة منسدلة مطاطة(لا تذكر المكرر الا مرة واحدة ولا تحتسب الفراغات) مربع بحث حسب الحروف( او الحرف الاول) google combo.rar

السلام عليكم أستاذ الظاهر ان موقع النور فيه نوع آخر من ملفات الاكسل ، والذي بشمل علامات لغتي الخالدة فقط ، عليه ، اليك طريقة استيرادهم ، بنفس الطريقة القديمة ، ولكن لجدول خاص به النموذج يطلب منك اختيار نوع ملف الاكسل ، والباقي يقوم الكود به . وهذا كود الاستيراد (طبعا هناك مجموعة من الاستعلامات في البرنامج): Option Compare Database Private Sub Browse_Click() Dim fpath As Variant With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Add "Excel Files", "*.xls ; *.xlsx" '.Filters.Add "Excel Files", "*.csv" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then Me.txtPath = .SelectedItems(1) End If End With Exit Sub End Sub Private Sub ImportData_Click() If Me.frm_Which_Type = 0 Then 'the user didn't choose anything, let him know MsgBox "رجاء اختيار اي نوع من الملفات تريد ان تستورد" & vbCrLf & "Please Select an option" Exit Sub ElseIf Len(Me.txtPath & "") = 0 Then 'don't leave the path empty MsgBox "رجاء اختيار ملف الاكسل" & vbCrLf & "Please select an Excel file" Exit Sub End If '1 'Empty Table Degrees and tbl_Sheets ' CurrentDb.Execute ("Delete * From Degrees") ' CurrentDb.Execute ("Delete * From tbl_Sheets") '2 'import Sheets Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean Dim lngCount As Long Dim objExcel As Object, objWorkbook As Object Dim colWorksheets As Collection Dim strPathFile As String, strTable As String Dim strPassword As String ' Establish an EXCEL application object On Error Resume Next Set objExcel = GetObject(, "Excel.Application") If Err.Number <> 0 Then Set objExcel = CreateObject("Excel.Application") blnEXCEL = True End If Err.Clear On Error GoTo 0 ' Change this next line to True if the first row in EXCEL worksheet ' has field names blnHasFieldNames = False ' Replace C:\Filename.xls with the actual path and filename strPathFile = Me.txtPath ' "C:\Filename.xls" ' Replace tablename with the real name of the table into which ' the data are to be imported strTable = "tbl_Sheets" '"tablename" ' Replace passwordtext with the real password; ' if there is no password, replace it with vbNullString constant ' (e.g., strPassword = vbNullString) strPassword = vbNullString '"passwordtext" blnReadOnly = True ' open EXCEL file in read-only mode ' Open the EXCEL file and read the worksheet names into a collection Set colWorksheets = New Collection Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , strPassword) For lngCount = 1 To objWorkbook.Worksheets.Count colWorksheets.Add objWorkbook.Worksheets(lngCount).Name Next lngCount ' Close the EXCEL file without saving the file, and clean up the EXCEL objects objWorkbook.Close False Set objWorkbook = Nothing If blnEXCEL = True Then objExcel.Quit Set objExcel = Nothing ' Import the data from each worksheet into the table For lngCount = colWorksheets.Count To 1 Step -1 'If lngCount <> 9 And lngCount <> 8 Then GoTo Next_lngCount '3 'Empty Table Degrees and tbl_Sheets 'j'CurrentDb.Execute ("Delete * From tbl_Sheets") CurrentDb.Execute ("Delete * From " & strTable) '-- '4 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _ strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$" '-- '5 If Me.frm_Which_Type = 2 Then 'the user choose Loqati ONLY add_Loqati = "_Loqati" Else add_Loqati = "" End If my_qry_Select = "qry_Select" & add_Loqati my_qry_Delete_Duplicate = "qry_Delete_Duplicate" & add_Loqati my_qry_Append = "qry_Append" & add_Loqati my_qry_Update_Sheet = "qry_Update_Sheet" & add_Loqati 'Delete Duplicate Dim rstQ As DAO.Recordset mySQL = "Select * From " & my_qry_Select Set rstQ = CurrentDb.OpenRecordset(mySQL) [F16] = rstQ![F16] [F8] = rstQ![F8] [F17] = rstQ![F17] [F29] = rstQ![F29] [F24] = rstQ![F24] rstQ.Close: Set rstQ = Nothing DoCmd.SetWarnings False DoCmd.OpenQuery my_qry_Delete_Duplicate DoCmd.SetWarnings True '------------- '6 'append the data DoCmd.SetWarnings False DoCmd.OpenQuery my_qry_Append DoCmd.SetWarnings True '------------- DoEvents Me.iSheet = colWorksheets.Count Me.iSheet2 = lngCount '------------- '7 'append the data DoCmd.SetWarnings False DoCmd.OpenQuery my_qry_Update_Sheet DoCmd.SetWarnings True '------------- '8 'empty tbl_Sheets CurrentDb.Execute ("Delete * From " & strTable) Next_lngCount: Next lngCount ' Delete the collection Set colWorksheets = Nothing MsgBox "Done" ' Uncomment out the next code step if you want to delete the ' EXCEL file after it's been imported ' Kill strPathFile End Sub جعفر 275.3.ImportDegrees.accdb.zip

السلام عليكم . هذا صحيح ، ولكن في نهاية الدالة تستطيع تختار النطاق Range او الورقة/sheet ، فعليه يمكنك ان تعيد الامر اكثر من مرة ، كل مرة لورقة اكسل اخرى (لاحظ اسماء الـSheet): DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet1$" DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet2$" DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet3$" . ولكن هذا الامر يتطلب منا ان نعرف عدد الاوراق/Sheets ، واسمائها ------------------------------------------------------------------------------------------------------------------------ والآن لشرح ما عملته انا: 1. عملت جدول اسمه tbl_Sheets ، لإدخال جميع المعلومات في جميع الاوراق/Sheets: . وعن طريق الكود (الكود سيكون في نهاية الموضوع) ، يأخذ البيانات ، فيصبح: . ثم يأتي الكود مرة اخرى ، فيملئ حقل ID لكل علامة: . ثم عملت استعلام جدولي CrossTab ، والذي به نستطيع ان نجعل بيانات احد الاعمدة عبارة عن اعمدة متفرقة ، يعني الحقل F1 ، اردنا ان نجعل كل مادة عبارة عن عمود مستقل): . وهذه نتائجه: . والان الى عمل استعلام آخر ، لجمع كل هذه السجلات: . فاصبحت: . الآن وقد اصبحت البيانات جاهزة لإلحاقها بالجدول النهائي Degrees ، نعمل استعلام الحاقي: . والكود الذي يقوم بكل العمل: Private Sub ImportData_Click() 'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet1$" 'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet2$" 'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_Sheets", Me.txtPath, False, "Sheet3$" Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean Dim lngCount As Long Dim objExcel As Object, objWorkbook As Object Dim colWorksheets As Collection Dim strPathFile As String, strTable As String Dim strPassword As String ' Establish an EXCEL application object On Error Resume Next Set objExcel = GetObject(, "Excel.Application") If Err.Number <> 0 Then Set objExcel = CreateObject("Excel.Application") blnEXCEL = True End If Err.Clear On Error GoTo 0 ' Change this next line to True if the first row in EXCEL worksheet ' has field names blnHasFieldNames = False ' Replace C:\Filename.xls with the actual path and filename strPathFile = Me.txtPath ' "C:\Filename.xls" ' Replace tablename with the real name of the table into which ' the data are to be imported strTable = "tbl_Sheets" '"tablename" ' Replace passwordtext with the real password; ' if there is no password, replace it with vbNullString constant ' (e.g., strPassword = vbNullString) strPassword = vbNullString '"passwordtext" blnReadOnly = True ' open EXCEL file in read-only mode ' Open the EXCEL file and read the worksheet names into a collection Set colWorksheets = New Collection Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _ strPassword) For lngCount = 1 To objWorkbook.Worksheets.Count colWorksheets.Add objWorkbook.Worksheets(lngCount).Name Next lngCount ' Close the EXCEL file without saving the file, and clean up the EXCEL objects objWorkbook.Close False Set objWorkbook = Nothing If blnEXCEL = True Then objExcel.Quit Set objExcel = Nothing ' Import the data from each worksheet into the table For lngCount = colWorksheets.Count To 1 Step -1 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _ strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$" Next lngCount ' Delete the collection Set colWorksheets = Nothing '--------------------------------- ' importing is finished 'now organize the table, by adding the ID to all the group Dim rst As DAO.Recordset Set rst = CurrentDb.OpenRecordset("Select * From tbl_Sheets") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 1 To RC If rst!F1 = "رقم الهوية" Then 'And Len(rst!ID & "") = 0 Then myID = rst!F2 rst.Edit rst!ID = myID rst.Update Else rst.Edit rst!ID = myID rst.Update End If rst.MoveNext Next i rst.Close: Set rst = Nothing 'append the data DoCmd.SetWarnings False DoCmd.OpenQuery "qry_Append_Sheets" DoCmd.SetWarnings True MsgBox "Done" ' Uncomment out the next code step if you want to delete the ' EXCEL file after it's been imported ' Kill strPathFile End Sub . . ولكن ، يجب عليك ان تحذف بيانات الجداول Degree و tbl_Sheets قبل ان تقوم بأي عمل جعفر 275.ImportDegrees.accdb.zip

اخى الكريم هل هذا هو التقرير الذى تريده ان كان ما تريد فاوشكت على الانتهاء منه بفضل الله وان لم يكن فاخبرنى

بسم الله الرحمن الرحيم ادرج اليكم ملف اكسل عن الإصدار الرابع من اعداد xlfdic و هو بالتأكيد مفيد جدا و إن شاء الله تستفيدوا منه و اردت اضافته و لما به من شرح جميل لعدد كبير من الدوال التي نحتاجها ملحوظه:- قد يكون ادرج في الموقع منذ زمن الإصدار الاول و لكن رأيت اعداد الموضوع لإستفاده الجميع او للتذكير به XLFDIC04.zip