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

وعليكم السلام تفضل اخي الكريم هل هذا هو المطلوب؟ بالتوفيق برنامج الحضور والغياب للطلاب بالباركود.accdb

السلام عليكم اعضاء واساتذة منتدانا الغالي هذه محاولة وتعديل لمشاركة احد الاخوة الكرام فيما يخص الصلاحيات لقاعدة البيانات اكواد تشفير الرقم السري هي نفسها المستخدمة سابقا بالاضافة مع الاستعانة ببعض الشروح ملاحظة : في القاعدة اربعة مستخدمين ثلاثة منهم بصلاحيات محدودة والادمن بصلاحيات كاملة اسم المستخدم كلمة السر admin 0 A 1 B 2 C 3 Root1000.rar

السلام عليكم تقضل طلبك كما في الصورة بعد التعديل مرفق ملفك تحياتي برنامج الحضور والغياب للطلاب بالباركود.rar

🙂

السبب هو عدد الحقول التي طلبتها ، اضف العلامة | في الدالة NZ ، بعددها في الكود بمعنى عندك 9 علامات : فلازم NZ يكون : جرب هذا A = Nz(DLookup("[ITEM_CODE] & '|' & [deskwn1] & '|' & [item_name] & '|' & [Expr1]& '|' & [Expr2] & '|' & [sub_id] & '|' & [FACTOR]& '|' & [UNT_ID]& '|' & [ITEM_CommissioN]& '|' & [CATEGORY]", "VW_ITEM_MASTAR", "[ITEM_BARCODE]='" & Me.ITEM_BARCODE & "'"), "|||||||||") جعفر

تفضل اكتب اي كلمة test34.xlsm

Try this file Offecna.xlsx

شاهد هذا الفيديو https://www.youtube.com/watch?v=0YNhxVu2a5s

اتفضل اخى حسين Me.EDET_QOTY = DLookup("[Qote_item]", "tabol102", "item_prais=" & [item_prais] & "and [ITEM_BARCODE]='" & Me.serh_Barcod & "'") DCount("ITEM_BARCODE", "tabol102", "ITEM_BARCODE = forms!forms_1!serh_Barcod and [item_prais]=forms!forms_1![item_prais]") test_1.accdb

جرب هذا الملف Ages.xlsx

بسم الله الرحمان الرحيم و الصلاة و السلام على أشرف المرسلين أما بعد: سوف نقوم اليوم إن شاء الله بشرح أداة WebBrowser وأهم ما يتعلق بها من أوامر و أحداث و خصائص و إدخال و إخراج. و سوف يتم تقسيم هذا العمل إلى مجموعة حلقات نبدأ من الصفر حتى آخر نقطة نستطيع الوصول إليها إن شاء الله مع وضع مثال تطبيقي لكل حلقة. مقدمة: WebBrowser هي أداة تعمل عمل أي متصفح و هي مقترنة المتصفح الشهير Internet Explorer فهي تساعدك في تصفح المواقع من ناحية و التحكم في أكواد HTML وكل ما يرتبط بها من إدخال و استخراج بيانات من ناحية أخرى. ملاحظة: لتشغيل هذه الأداة بشكل جيد يجب تحديث المتصفح الشهير Internet Explorer إلى الإصدار 10 أو 11. مع العلم أن ونداوز 10 به الإصدار 11 الحلقة الأولى: أكواد التصفح سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من التصفح و التنقل داخل الأداة. 1- كود فتح صفحة موقع: WebBrowser3 هو اسم الأداة داخل النموذج Me.WebBrowser3.Navigate ("رابط الصفحة كامل") 2- كود فتح صفحة فارغة: Me.WebBrowser3.Navigate ("about:blank") 3- كود الرجوع للصفحة السابقة: Me.WebBrowser3.GoBack 4- كود الإنتقال للصفحة التالية: Me.WebBrowser3.GoForward 5- كود إعادة تحميل الصفحة: Me.WebBrowser3.Refresh 6- كود إيقاف تحميل الصفحة: Me.WebBrowser3.Stop 7- كود إستخراج رابط الصفحة الحالية: MsgBox Me.WebBrowser3.Document.url و هذا مثال لما تم ذكره في هذه الحلقة webbroser.rar

السلام عليكم 🙂 اخواني ، الجميع يساعد في المنتدى بوقته وبدون مقابل ، وعندنا مثل يقول: حبة الزبيب ما تشبّع ، ولكنها تحلّي الفم 🙂 فرجاء خلونا نشجع الاعضاء في العطاء 🙂 لما تحصل على رد له قيمة ، فتشجيعا للعضو الذي يساعدك ، اخبر العضو بأنك مُعجب برده ، هكذا : . . ولما تحصل على اجابة لسؤال موضوعك ، فرجاء اختيار افضل اجابة ، هكذا (حتى مستقبلا يسهل معرفة الاجابة الصحيحة) : . شكرا 🙂 جعفر ومع الاعتذار لأخي احمد لإستخدام اسمه في المثال 🙂

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

بعد اذن استاذ محمد يتم الترحيل بعد تنشيط الورقة باسم all test_2.xlsm

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

1. نحن في النموذج Form1 ، ونريد ان نستعمل القيم من النموذج المفتوح Form2 : Me.ITEM_BARCODE = DLookup("[ITEM_BARCODE]", "VW_ITEM_MASTAR", "[ITEM_BARCODE]='" & Forms!forms1!serh_Barcod & "'") Me.ITEM_CODE = DLookup("[ITEM_CODE]", "VW_ITEM_MASTAR", "[ITEM_BARCODE]='" & Forms!forms1!item_no & "'") 2. نحن في النموذج Forms2 ، ونريد ان نرسل القيم الى النموذج المفتوح Forms1 : Forms!forms1!serh_Barcod = DLookup("[ITEM_BARCODE]", "VW_ITEM_MASTAR", "[ITEM_BARCODE]='" & Me.ITEM_BARCODE & "'") Forms!forms1!item_no = DLookup("[ITEM_CODE]", "VW_ITEM_MASTAR", "[ITEM_BARCODE]='" & Me.ITEM_CODE & "'") جعفر

السلام عليكم في تذييل التقرير اكتب في مربع نص غير منضم الكود التالي =Count(*) تحياتي Database2.rar

الحمدالله تم عمل الازم تمام التمام شكرا خالد

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير والحمدلله الذى بنعمته تتم الصالحات بالتاكيد هذه الهديه من روائع اخى واستاذى جعفر ويسرت على ايضا كثيرا جزاك الله عنا كل خير لما استخدمته جعلته فى حال لم لم يجد قيم فيضع اصفار فالحقول كالتالى LN = DLast("[Post] & '|' & [Mtar] & '|' & [EmsD] & '|' & [EmsKh] & '|' &[Draeb]", "THrkat_Emp", "[THrkat_Emp.KodT]=[TKhtotKodT] and [THrkat_Emp.ID_Kind ]='N3'") If IsNull(LN) Then LN = ("0 | 0 | 0 | 0 | 0") X = Split(LN, "|") Me.[LPost] = X(0) Me.[LMtar] = X(1) Me.[LEmsD] = X(2) Me.[LEmsKh] = X(3) Me.[LDraeb] = X(4) Else X = Split(LN, "|") Me.[LPost] = X(0) Me.[LMtar] = X(1) Me.[LEmsD] = X(2) Me.[LEmsKh] = X(3) Me.[LDraeb] = X(4) End If واليك تعديل على مثالك بهديه اخى واستاذى جعفر جزاه الله خيرا Private Sub ITEM_BARCODE_AfterUpdate() a = DLookup("[SELLS_PRICE]& '|' & [item_name]", "POS_MASTER", "[ITEM_BARCODE]=forms!forms_1!ITEM_BARCODE") If IsNull(a) Then a = (" | ") X = Split(a, "|") Me.SELLS_PRICE = X(0) Me.ITEM_NAME = X(1) Else X = Split(a, "|") Me.SELLS_PRICE = X(0) Me.ITEM_NAME = X(1) End If End Sub وفى انتظار تعقيب اخى واستاذى العزيز جعفر تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق test_102.rar

ما شاء الله جميل

بالانتظار استاذي شكرا لك

السلام عليكم يمكن عمل ذلك بسهوله من خلال دالة Between بالاستعلام تحياتي انتظرني قليلا

وعليكم السلام-تفضل hours1.xls

استاذي الفاضل jjafferr بخصوص هذا الكود انه ممتاذ جدا انا جربته فوق الممتاز وفر علي جهود كثيره زادك الله من علمه وجعله في ميزان حسناتك Dim x() As String A = DLookup("[pn] & '|' & [Size] & '|' & [Vendor] & '|' & [Description] & '|' & [Maxrl] & '|' & [Maxrlegyptair] & '|' & [actype] & '|' & [pos] & '|' & [biasradial] & '|' & [code]", "code", "[pn]=forms!frm_dataentry!Combopn") x = Split(A, "|") ' For i = LBound(x) To UBound(x) ' Debug.Print x(i) ' Next i Me.pn = x(0) Me.size = x(1) Me.vendor = x(2) Me.Description = x(3) Me.Maxrl = x(4) Me.Maxrlegyptair = x(5) Me.ACType = x(6) Me.Pos = x(7) Me.BiasRadial = x(8) Me.code = x(9)

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

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

السلام عليكم هل تقصد تحديث النموذج الفرعي Sub per Line الموجود غي النموذج الرئيسي Main per Line بواسطة الزر Calculate المهم وجدت هذا الكود في حدث عند نقر زر Calculate انت عامله لفتح استعلام ؟؟؟ DoCmd.OpenQuery "Main TABL, acViewNormal, acReadOnly" تحياتي انظر للمرفق DRI Plant # 01.rar

جرب هذه المعادلة =EDATE($A$1,$A$2)

وعليكم السلام ورحمة الله وبركاته =DATE(YEAR(A1);MONTH(A1)+B2;DAY(A1)) =DATE(YEAR(A1);MONTH(A1)+3;DAY(A1)) معادلتين : إما كتابة الرقم المضاف أو تعيين خلية لإضافة الرقم للشهر المعادلة تؤدي الغرض ويمكن للأساتذة أضافة نستفيد منها Month+3.xlsx

وعليكم السلام 🙂 اسمح لي اشارك معاك اخوي خالد 🙂 انا شايف ان الرقم العشوائي مجرد تمويه ، او لم يتم استعماله بالطريقة الصحيحة في الكود !! الكود يطلب منك كلمة السر ويحتفظ بها في المتغير x ، المتغير z يعمل عملية حسابية على كلمة السر التي ادخلتها ، اذا كانت كلمة السر صحيحة ، فيخبرك انها صحيحة ويفتح لك النموذج "معلومات التقارير" ، واذا كانت فيخبرك انها خطأ ويغلق النموذج "معلومات التقارير" !! ولكن النموذج "معلومات التقارير" : يا انه مُغلق ، فيتم فتحه ، او مفتوح فيتم غلقه ، ولكن الكود يعمل الاثنين ، حسب صحّة كلمة السر !! جعفر

جرب هذا الملف My_Book.xlsm

وهذا ما يفعله الكود الذي رفعته لك بالضبط (لكن بدون رقم سري ) اذا اردت يمكن وضع رقم سري بالكود

تحية طيبة وعطرة... تفضل ما طلبته في الملف المرفق... بن علية حاجي Cash at Banks (TEST).xlsm

السلام عليكم ورحمة الله تم عمل المطلوب في الملف المرفق... أرجو أن تفي الغرض المطلوب.. بن علية حاجي ملاحظة: تم تصحيح خطأ في المعادلة الثانية للإحداثيات في الملف المرفق (خطأ في الإشارة).. معذرة لذلك... (النتائج المحصل عليها تمت في معلم متعامد ومتجانس) Circle & Center.xls

لم أفهم سؤالك جيداَ يمكنك الذهاب الى اي خلية رقم عامودها اكبر من 3 هناك طريقة ثانية بحماية الصفحة مع عدم السماح بالتحرير في هذه الثلاثة أعمدة مثلاً Sub Protct_Three_columns() With Sheets("ورقة1") .Unprotect .ScrollArea = "" .Cells.Locked = False .Range("A3:c3").EntireColumn.Locked = True .Protect End With End Sub

تفضل اخي حسب مافهمت من طلبك اتمنى يكون المطلوب MM-2.rar

لقد وضعت ملفاً بهذا الموضوع قبل ان ترفع مثالك ارجو ان يكون المطلوب الكود Option Explicit Sub Copy_By_Choise() Rem Created By Salim Hasbays On 1/3/2020 Application.ScreenUpdating = False On Error GoTo End_Me Dim S As Worksheet, T As Worksheet Dim i%, col%, X%, Last%, m%, k%, Howmay_row% Dim Title_arr Set S = Sheets("Source"): Set T = Sheets("Target") col = T.Cells(2, Columns.Count).End(1).Column If col = 1 Then col = 500 Howmay_row = S.Range("G2") Title_arr = Application.Transpose(S.Range("a1:d1")) Title_arr = Application.Transpose(Title_arr) Last = S.Cells(Rows.Count, 2).End(3).Row T.Range("A2").Resize(Last, col).Clear m = 3: k = 1 For i = 2 To Last For X = 0 To 3 T.Cells(m, k).Offset(, X) = _ S.Cells(i, 1).Offset(, X) Next X m = m + 1 If m Mod (Howmay_row + 3) = 0 Then m = 3: k = k + 5 Next i col = T.Cells(3, Columns.Count).End(1).Column For k = 1 To col Step 5 Cells(2, k).Resize(, 4) = Title_arr With T.Range("B2").Offset(, k - 1).CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 End With Next Erase Title_arr: Set S = Nothing: Set T = Nothing End_Me: Application.ScreenUpdating = True End Sub الملف مرفق Split_table.xlsm

شكراً استاذ محسن و لي انا بهذا الشأن هذا الماكرو (عسى ان ينال الإعجاب) Option Explicit Sub S_H_Test_NEW() Dim D As Worksheet: Set D = Sheets("Data") Dim M As Worksheet: Set M = Sheets("المطلوب") Dim ARR(): ARR = Array("S", "G", "C", "H") Dim Obj As Object, i%, Chek%, t% Set Obj = CreateObject("Scripting.Dictionary") M.Range("K2").CurrentRegion.ClearContents i = 2 Do Until D.Range("F" & i) = vbNullString For t = 1 To 4 Chek = Chek + (UCase(M.Cells(2, t)) = _ UCase(D.Cells(i, ARR(t - 1)))) Next If Chek = -4 Then _ Obj.Add i, D.Cells(i, "F") i = i + 1: Chek = 0 Loop If Obj.Count Then _ M.Cells(2, "k").Resize(Obj.Count) = _ Application.Transpose(Obj.items) Set Obj = Nothing: Set D = Nothing: Set M = Nothing Erase ARR End Sub الملف من جديد MY_search_MD_SH.xlsm

مبدع دائما أستاذنا الكبير / سليم وإثراء للموضوع يمكن تجربة الكود التالى لاستدعء البيانات بأكثر من شرط Option Explicit Sub M_D_Test() Dim ws As Worksheet: Set ws = Sheets("Data") Dim sh As Worksheet: Set sh = Sheets("المطلوب") Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim lr As Long, I As Long, j As Long, P As Long lr = ws.Range("C" & Rows.Count).End(xlUp).Row '------------------------------------ Application.ScreenUpdating = False sh.Range("H2:H22").ClearContents Arr = ws.Range("A2:Z" & lr).Value '=================== Arr1 = Array(5) '==================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For I = 1 To UBound(Arr) ' الـ 3 شروط ' ================================================================================================== If Arr(I, 19) = sh.[A2].Value And Arr(I, 7) = sh.[B2].Value And Arr(I, 3) = sh.[C2].Value Then '================================================================================================== P = P + 1 For j = 0 To UBound(Arr1) Temp(P, j) = Arr(I, Arr1(j)) Next j End If Next I If P > 0 Then sh.Range("H2").Resize(P, UBound(Temp, 2)).Value = Temp '------------------------------------ Application.ScreenUpdating = True End Sub MY_search_MD.xlsm

جرب هذا الملف MY_search.xlsx

السلام عليكم ورحمة الله جرب المرفق لعل فيه ما تريد... يمكن عمل ذلك بدالة مستحدثة عن طريق VBA (والذي هو ليس من امكانياتي)... بن علية حاجي فصل أيام الغياب.xlsx

شيت مستر ملاك 2020 للمرحلة الإبتدائية شيت كنترول كامل لكل الصفوف من الأول الى السادس الابتدائى على أحدث التعليمات الواردة من الوزارة حسب قرار 311 الصادر فى 28 / 11 / 2019 و الخاص بتعديل مادة التربية الرياضية يحتوى على : 1- البيانات الاساسية 2- كشوف مناداة التلاميذ 3- لاصقات أرقام الجلوس 4- أرقام الجلوس مع جدول الامتحانات 5- قوائم الفصول 6- كشوف درجات المواد و الانشطة 7- شيت متكامل 8- نتيجة شاملة 9- احصاء 10- احصاء الجودة 11- الشهادات تقديرات فقط و تقديرات و درجات معاً 12- العشرة الأوائل 13- شهادات تقدير للأوائل يتميز بــ : سهولة التعامل صغر الحجم شامل كل المعلومات المطلوبة فى الامتحانات طباعة سريعة لكل صفحات الشيت بضغطة واحدة امكانية الترتيب الأبجدى بضغطة واحدة مع قبول أى اقتراحات جديدة كلمة المرور : 333 التحميل : http://www.mediafire.com/file/0dhgmo0446n5bwy/%D8%B4%D9%8A%D8%AA_%D9%85%D8%B3%D8%AA%D8%B1_%D9%85%D9%84%D8%A7%D9%83_2020_%D9%84%D9%84%D9%85%D8%B1%D8%AD%D9%84%D8%A9_%D8%A7%D9%84%D8%A5%D8%A8%D8%AA%D8%AF%D8%A7%D8%A6%D9%8A%D8%A9_20-1-2020.rar/file

جرب هذا الماكرو Option Explicit Sub Join_by_three() Dim my_rg As Range Dim lr%, i%, col%, m%, k% col = Cells(1, Columns.Count).End(1).Column lr = Range("a2", Range("A1")).End(4).Row m = lr + 2 Range("a" & m).Resize(10000, 3 * col).Clear For i = 1 To lr Step 3 For k = 0 To 2 Range("a" & i + k).Resize(, col).Copy _ Range("a" & m).Offset(, k * col) Next k m = m + 1 Next i End Sub MY_one_file.xlsm

الحلقة الرابعة: التعامل مع القائمة المنسدلة في صفحة ويب سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من التحكم الكامل في القائمة المنسدلة داخل الأداة في صفحة ويب لقد قمت بتطبيق هذا الدرس على موقع الفايس بوك لأن به قائمة منسدلة الخاصة بالأشهر و لها خاصية: Id=month لهذه القائمة عمودين عمود مخفي و هو يمثل القيمة الحقيقة به أرقام من 0 إلى 12 و عمود ظاهر به أسماء الأشهر 1- كود حساب عدد عناصر القائمة: MsgBox Me.WebBrowser3.Document.getElementById("month").Length 2- كود معرفة القيمة الحقيقية للعنصر: من المعلوم أن القائمة المنسدلة يمكن أن يكون بها أكثر من عمود يعني ممكن تصبح القيمة الظاهرة تختلف عن القيمة الحقيقية MsgBox Me.WebBrowser3.Document.getElementById("month").Value 3- كود استخراج ترتيب القيمة الظاهرة: استخراج ترتيب القيمة الظاهر ضمن عناصر القائمة المنسدلة MsgBox Me.WebBrowser3.Document.getElementById("month").selectedIndex 4- كود استخراج القيمة الظاهرة: MsgBox Me.WebBrowser3.Document.getElementById("month").Item(Me.WebBrowser3.Document.getElementById("month").selectedIndex).innerText 5- إظهار جميع عناصر القائمة: Dim x As String Dim i As Integer For i = 1 To Me.WebBrowser3.Document.getElementById("month").Length x = x & " - " & Me.WebBrowser3.Document.getElementById("month").Item(i - 1).innerText Next i MsgBox x 6- اختيار عنصر من القائمة باستخدام رقمه الترتيبي: هنا وضعت القيمة تساوي 5 معناه سوف يتم اختيار العنصر رقم 5 و هو مايو Me.WebBrowser3.Document.getElementById("month").selectedIndex = 5 7- تغيير نص قيمة في العمود الظاهر من القائمة: سوف يتم تغيير كتابة أفريل في القائمة إلى أوفيسنا Me.WebBrowser3.Document.getElementById("month").Item(4).innerText = "أوفيسنا" 8-تغيير قيمة في العمود المخفي من القائمة: Me.WebBrowser3.Document.getElementById("month").Item(4).Value = "15" قبل البداية في تطبيق درس اليوم اضغط على زر فتح صفحة الفايس بوك لتظهر الصفحة أمامك webbroser.rar

جرب هذا الكود تم تغيير اسماء الشيتات الى اللغة الاجنبية لسهولة التعامل مع الكود من حيث النسخ واللصق Option Explicit Private Sub Worksheet_Activate() FIL_CDATA_VAL End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub FIL_CDATA_VAL() Dim i As Long: i = 8 Dim DIC As Object Set DIC = CreateObject("Scripting.Dictionary") Do Until Sheets("DATA").Range("C" & i) = vbNullString DIC(Sheets("DATA").Range("C" & i).Value) = "" i = i + 1 Loop With Sheets("RESULT").Range("k5").Validation .Delete .Add 3, Formula1:=Join(DIC.KEYS, ",") End With Set DIC = Nothing End Sub '++++++++++++++++++++++++++++++++++++++++ Sub GET_CERTIFICAT() Dim dat As Worksheet, RES As Worksheet Dim Num%, k%, R, i%, Found_Ro%, Ro%: Ro = 8 Dim FOUND_RG As Range Dim n: n = 3 Dim arr Set dat = Sheets("DATA"): Set RES = Sheets("RESULT") Union(RES.Range("c5"), RES.Range("c19"), RES.Range("c33")) = vbNullString Union(RES.Range("c8:k9"), RES.Range("c22:k23"), RES.Range("c36:k37")) = vbNullString Num = RES.Range("K5") arr = Array(2, 5, 7, 9, 11, 13, 15, 17, 19, 21) For k = 1 To n Set FOUND_RG = dat.Range("a8").CurrentRegion.Columns(3). _ Find(Num, LOOKAT:=1) If FOUND_RG Is Nothing Then Exit Sub R = FOUND_RG.Row RES.Cells(Ro - 3, 3) = dat.Cells(R, arr(0)) For i = 1 To UBound(arr) With RES.Cells(Ro, 3).Offset(, i - 1) .Value = dat.Cells(R, arr(i)) .Offset(1) = dat.Cells(R, arr(i) + 1) End With Next RES.Cells(Ro + 2, 3) = dat.Cells(R, 23) Num = Num + 1: Ro = Ro + 14 Next End Sub الملف مرفق RESULT.xlsm

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

أبدأ بحمد الله أولا وأخيرا على ما انعم ووفق وأصلي واسلم على الرحمة المهداة والسراج المنير نبينا محمد وعلى آله وصحبه وسلم ... وبعد في أحدي الموضوعات علي منتدانا الكريم وفي موضوع لاحد الأخوة بطلب برنامج ليتمكن من ادارة الأشتراكات الشهرية (اشتراكات DSL - كروت - توزيع شبكات انترنت او شبكات الكابل التلفزيوني ) وما الي ذلك من الاشتراكات التي تحتاج لمتابعة شهرية علي انتهاء صلاحية اسم المستخدم مثلا او متابعة حركة السداد المختلفة لذلك وفقني الله سبحانه وتعالي لتلك الفكرة بعمل برنامج يقوم بمتابعة تلك الاشتراكات الشهرية ومتابعة سداد وعمل وطباعة تقارير عن المديونية والمبيعات وكشف حساب للعميل وما الي ذلك من العمليات التي يمكن ان يحتاجها المستخدم لادارتها وكذلك ادخال اغلبية البيانات تلقائيا كرقم ايصال السداد مسلسل العميل تاريخ نهاية الاشتراك وادعو الله سبحانه وتعالي ان اكون وفقت في البرنامج وان يكون فيه النفع ويمكن تطويع البرنامج ليتلائم مع ادارة المشروعات الفردية الصغيرة ايضا ولا تنسونا من دعوة صالحة في ظهر الغيب بصلاح الحال ناتي لشرح بعض خصائص البرنامج المختلفة أترككم لتجربة البرنامج في المرفقات وارحب بمشاركتكم في اجراء اية تعديلات وفقنا الله واياكم للصالحات مع تحياتي // ضاحي الغريب Manage Subscriptions By Dahy al Gharieb.rar

السلام عليكم أخي محمد انا لن اتطرق لطريقة عمل النموذج الجديد ، "لأننا" لم نلحظ المشكلة في النموذج الاصل ولكني دخلت في كود Combopn_AfterUpdate : pn = DLookup("pn", "code", "[pn]=forms!frm_dataentry!Combopn") size = DLookup("Size", "code", "[pn]=forms!frm_dataentry!Combopn") vendor = DLookup("Vendor", "code", "[pn]=forms!frm_dataentry!Combopn") Description = DLookup("Description", "code", "[pn]=forms!frm_dataentry!Combopn") Maxrl = DLookup("Maxrl", "code", "[pn]=forms!frm_dataentry!Combopn") Maxrlegyptair = DLookup("Maxrlegyptair", "code", "[pn]=forms!frm_dataentry!Combopn") ACType = DLookup("actype", "code", "[pn]=forms!frm_dataentry!Combopn") Pos = DLookup("pos", "code", "[pn]=forms!frm_dataentry!Combopn") BiasRadial = DLookup("biasradial", "code", "[pn]=forms!frm_dataentry!Combopn") code = DLookup("code", "code", "[pn]=forms!frm_dataentry!Combopn") لاحظت انك تنادي الجدول (اي تعمل استعلام للجدول) 10 مرات !! انا دائما لما اعمل برامجي ، اعمل البرنامج على اساس انه سيكون عبارة عن جزئين ، الواجهة FE ، والجداول BE ، وان الجداول BE ، ستكون في شبكة ، وان الواجهة FE ستكون لأكثر من مستخدم. لهذا السبب ، فيجب ان نقلل الزحمة في الشبكة ، وذلك بتقليل زيارة/استعلام الجداول قدر الإمكان ، وعند كل زيارة ، يجب ان نأخذ اكبر كمية من البيانات المطلوبة ، ثم نتعامل معها محليا في FE. لذلك ، فانا هنا اعطيك احد البدائل (والتي لا يعرفها الكثير ، لأنها تعمل على الاكسس 2003 فما فوق) ، فالكود التالي ، يقوم بزيارة/استعلام الجدول عن طريق DLookup مرة واحدة ، ويأخذ 10 بيانات مرة واحدة ، فلذا يمكن ان يستبدل كودك اعلاه: Dim x() As String A = Nz(DLookup("[pn] & '|' & [Size] & '|' & [Vendor] & '|' & [Description] & '|' & [Maxrl] & '|' & [Maxrlegyptair] & '|' & [actype] & '|' & [pos] & '|' & [biasradial] & '|' & [code]", "code", "[pn]=forms!frm_dataentry!Combopn"),"|||||||||") 'ويمكن استعمال اي شيء بدل عن | فمثلا الفاصلة 'A حتى اذا لم هناك قيمة للمتغير Nz نستعمل الدالة 'عدد مرات وضع العلامة | في نهاية السطر ، يكون نفس عددها في المعادلة 'لهذا السبب نرى اننا وضعنا 9 منها في نهاية السطر x = Split(A, "|") ' For i = LBound(x) To UBound(x) ' Debug.Print x(i) ' Next i Me.pn = x(0) Me.size = x(1) Me.vendor = x(2) Me.Description = x(3) Me.Maxrl = x(4) Me.Maxrlegyptair = x(5) Me.ACType = x(6) Me.Pos = x(7) Me.BiasRadial = x(8) Me.code = x(9) جعفر

الأستاذ / وائل البسطي السلام عليكم ورحمة الله وبركاته إليك الملف به المطلوب. الرقم القومي.rar

اخي والله الكود عندي يعمل بشكل طبيعي لكن جرب التالي ـ 1 ) كون مجلد و سمه RR و ضع فيه ملغات شرط ان تكتب في الخلية A1 من كل ملف قيمة معينة ـ 2 ) انشأ مجلدا آخر و ضع فيه المجلد السابق ـ 3 ) انشأ ملف اكسل ثم افتحه ـ 4 ) اذهب الى محرر VB ثم اضف موديل و انسخ فيه الموديل التالي : Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _ (ByVal lpRootPath As String, _ ByVal lpInputName As String, _ ByVal lpOutputName As String) As Long Public Const MAX_PATH = 260 Public Function FindFile(RootPath As String, _ FileName As String) As String Dim lNullPos As Long Dim lResult As Long Dim sBuffer As String On Error GoTo FileFind_Error sBuffer = Space(MAX_PATH * 2) lResult = SearchTreeForFile(RootPath, FileName, sBuffer) If lResult Then lNullPos = InStr(sBuffer, vbNullChar) If Not lNullPos Then sBuffer = Left(sBuffer, lNullPos - 1) End If FindFile = sBuffer Else FindFile = vbNullString End If Exit Function FileFind_Error: FindFile = vbNullString End Function ـ 5 ) اذهب الى صفحة Workbook و افتحها و انسخ الكود الاتالي في الحدث Workbook_Open الكود : Private Sub Workbook_Open() ورقة1.Range("A1:A50").ClearContents Set Files = Application.FileSearch With Files .LookIn = ThisWorkbook.Path + "\RR" .FileName = "*.xls" If .Execute > 0 Then For i = 1 To .FoundFiles.Count ورقة1.Cells(i + 1, 1) = .FoundFiles(i) Next i Else MsgBox "لا يوجد ملفات في المسار" & vbNewLine & ThisWorkbook.Path + "\F", vbInformation, "خطأ" End If End With End Sub ـ 6 ) أنشأ في الصفحة الاولى من الملف زر و قم بنسخ الكود التالي في هذا الزر : Private Sub CommandButton1_Click() LastRow = Cells(Rows.Count, "D").End(xlUp).Row '+ 1 On Error Resume Next Dim xl As New Excel.Application Dim xlw As Excel.Workbook Dim Vr As String Vr = ThisWorkbook.Path & "\RR" For n = 1 To 10 Set xlw = xl.Workbooks.Open(Cells(n + 1, 1)) xlw.ورقة1.Range("A1").Select Cells(LastRow + n, 4).Value = xlw.Application.Range("A1").Value xlw.Close False Next LR = Cells(Rows.Count, "D").End(xlUp).Row For t = 1 To LastRow s = LR Cells(1, 5).Formula = "=Sum(D1:D" & s & ")" Next End Sub الآن احفظ الملف في المجلد الثاني الذي أنشأته و اخرج منه ثم اعد فتحه من جديد فإن وجدت في الصفحة الاولى اسماء الملفات التي وضعتها في المجلد RR فالعمل صحيح ما بقي الا الضغط على الزر و ان لم تجد . . . . . . . فالله اعلم بالخطأ الذي وقع