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

اشكرك اخي الكريم : كلامك يحتاج حكحكة رأس ( على قول جعفر ) ..... أعطني فرصة للتفكير ....

تفضل ..... رسائل.accdb

وعليكم السلام-يمكنك تجربة ورؤية هذا الرابط https://www.officena.net/ib/topic/82235-لون-الخط-في-صندوق-الرسائل-msgbox/

تفضل عندما تريد ترتيباً تصاعدياً تقوم بكتابة رقم 1 فى الرسالة الحوارية و -1 عندما تريد ترتيباً تنازلياً الوزن.xlsm

لو ممكن رفع الملف للتجربة

عليك بفتح مديول جديد ووضع هذا الكود به وربطه بزر Sub xlSortSheets_Test() Dim strWhich As String Dim Which As Integer strWhich = InputBox("لترتيب أسماء الأوراق تصاعدياً أدخل الرقم 1 " & vbNewLine & "لترتيب أسماء الأوراق تنازلياً أدخل الرقم -1 ", "تحديد طبيعة ترتيب أسماء الأوراق", "1") If strWhich = vbNullString Then Exit Sub If strWhich = "-1" Or strWhich = "1" Then Which = strWhich Call xlSortSheets(Which) Exit Sub End If MsgBox "لم تدخل الأرقام المسموح بها لعمل الترتيب" & vbCrLf & "لم يتم ترتيب الأوراق", vbOKOnly End Sub Sub xlSortSheets(Optional Which As Integer = 1) Dim I As Integer Dim J As Integer Dim SheetNames() As String Dim temp As String ReDim SheetNames(Sheets.Count) For I = 1 To Sheets.Count SheetNames(I) = Sheets(I).Name Next I For I = 1 To Sheets.Count - 1 For J = I + 1 To Sheets.Count If (Which = -1 And SheetNames(I) < SheetNames(J)) _ Or _ (Which = 1 And SheetNames(I) > SheetNames(J)) Then temp = SheetNames(I) SheetNames(I) = SheetNames(J) SheetNames(J) = temp End If Next J Next I temp = Sheets(Sheets.Count).Name For I = Sheets.Count To 1 Step -1 Sheets(SheetNames(I)).Select Sheets(SheetNames(I)).Move Before:=Sheets(temp) temp = SheetNames(I) Next I Sheet1.Select End Sub

وعليكم السلام -بارك الله فيك أستاذ عبد اللطيف بالتأكيد هناك ترتيب وكما تشاء سواء تصاعدياً أو تنازلياً -كما بهذا الرابط https://www.officena.net/ib/topic/33468-هل-يمكن-ترتيب-اسماء-شيت-الاكسيل-ابجدي/ وهذا هو الملف ترتيب الأوراق حسب أسمائها.xls

اتفضل أخى الكريم ضع الكود التالى فى حدث الفورم سيظهر لك التكست بوكس 1 يحتوى على الوقت تلقائيا الكود Private Sub UserForm_Activate() Me.TextBox1 = Format(Date, "h:mm AM/PM;@") End Sub

وعليكم السلام-تفضل Fuddruckers OD Jun 2019.xlsx

اعرض الملف كود لتحويل مصفوفة إلى عمود واحد رأسي اجتجت الي تجويل البيانات فى مصفوفات الى عمود واجد رأسي ، فقمت باعداد هذا الملف و هذا هو الكود و يجب تظليل (اختيار) المصفوفة المطلوب تحويلها لعمود قبل تشغيل الكور اختار المصفوفة ثم اضغط على الزر ملاحظة : بفضل تجميل الاصدار الاخير الذي يظهر اسفل الصفحة لانه به ميزة اضافية Sub MakeOneColumn() Dim Myrows As Integer, Mycols As Integer Myrows = Selection.Rows.Count Mycols = Selection.Columns.Count With ActiveCell For i = 0 To Mycols '6 For j = 0 To Myrows '3 .Offset(Myrows * (i) + j) = .Offset(j, i) Next j Next i End With End Sub الكود المعدل فى الاصدار التاني ، للتشغيل اختار البيانات دون رؤس الأعمدةو الصفوف Sub MakeOneColumn() Dim Myrows As Integer, Mycols As Integer Myrows = Selection.Rows.Count Mycols = Selection.Columns.Count With ActiveCell For i = 0 To Mycols - 1 For j = 0 To Myrows - 1 ' record matrix value .Offset(Myrows * (i) + Myrows + 1 + j, 1) = .Offset(j, i) ' record Row .Offset(Myrows * (i) + Myrows + 1 + j, -1) = .Offset(j, -1) ' record Col .Offset(Myrows * (i) + Myrows + 1 + j, 0) = .Offset(-1, i) Next j Next i End With End Sub صاحب الملف محمد طاهر تمت الاضافه 10 يول, 2019 الاقسام قسم الإكسيل

هذا البرنامج أعد وفق القواعد الشرعية وهو البرنامج الحصرى لحساب الميراث والوصايا بالأكسل (excel) يفضل نسخة 2007 فما فوق مهندس خالد الطاهر حدادة khaledhadada47@gmail.comhttps://www.facebook.com/groups/1436631679886258/ ملفات مرفقة الفرائض والوصايا بالأكسل أعداد م خالد حدادة.rar

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

[level] تعيد سلسلة نصية عبارة عن اسم الشريحة في الاستعلام: قم بإنشاء عمود جديد باسم pay مثلا ثم مرر عليه الوظيفة على أن تكون قيمة المحدد الثالث (4)؛ بهذا تحصل على قيمة تمثل قيمة الرسوم والدمغات لنفس مستوى الشريحة ثم قم بوظعه بدلا عن [level]

أهلا @محمد احمد لطفى جمعت لك البيانات كلها في وضيفة واحدة وسميتها ()Cons0819 الأرقام في اسم الوظيفة يدل على الشهر والسنة للوظيفة ثلاث محددات: تاريخ الاستهلاك، وكمية الاستهلاك، ودليل البيانات الراجعة كتبت في الوظيفة تفسيرا لقيمة البيانات الراجعة قمت بوضع بعض القيمة الراجعة من الوظيفة بجوار نظيرها في الاستعلام من أجل إجراء مقارنة سريعة للتأكد صحة البيانات المهم أن الوظيفة ينقصها بعض المراجعة والضبط مع متطلباتك.. أرجو التكرم بالمراجعة.. إليك التعديل: كهرباء 2019.mdb

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

بالفعل أستاذ احمد لو حضرتك لاحظت تم دمج هذه المشاركات بالفعل من قبل هنا لأنهما نفس الطلب ونفس الموضوع

عليك السلام ورحمة الله وبركاته تم معالجة حرف ال غ في مجموع مادة الرياضيات والمجموع الكلي احصائيةالفصل 2الدراسى الأول 2019_3.xls

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

السلام عليكم ورحمة الله وبركاته 🙂 في الواقع ، عرضت هذا الموضوع في منتدى الفريق العربي للبرمجة سابقا ، ولكني اعرضه هنا ، حتى تعم الفائدة ويستفيد منه الجميع. في بعض الاحيان نعمل برنامج بلغة معينة (العربية مثلاً) ، ثم لاحقا نريد هذا البرنامج لمستعملين بلغة اخرى (الانجليزية او الفرنسية مثلاً) ، مما يضطرنا ان نعمل نسخة اخرى من البرنامج 😞 اضع بين يديكم طريقة عمل برنامج بعدة لغات ، والطريقة هي الاحتفاظ بالمعلومات المطلوبة (ولا اقصد البيانات) في جدول. 1. هذه هي البيانات بلغات 3 ، العربية والانجليزية والفرنسية (والكلمات تم ترجمتها من الانجليزية الى الفرنسية عن طريق Google Translation): الخانات الموجودة بسيطة ومعرفة معناها لا يأخذ وقت ، اما تنسيق الحقل فهو:1. اسم الخط ، 2. حجم الخط ، 3. ثخانة الخط ، 4. منحني ، 5. تحته خط ، 6. لون الخط: 2. النموذج الرئيسي ، به واجهة البرنامج (والتي سنراها على الجهة اليمنى من الشرائح التالية) ، واول نموذج هو لعمل التغييرات على تنسيق الحقل ، وذلك بالنقر المزدوج في الحقل ، فتنفتح لنا نافذة اختيار الخط ، وعندما نطمئن لإختيارنا للخط ، يجب ان نحفظ هذا التنسيق ، وذللك للّغة التي نريدها: 3. اما النتائج المرجوة من البرنامج ، فتظهر لنا في هذا النموذج: باللغة العربية: باللغة الانجليزية: وباللغة الفرنسية: والكود الذي يقوم بجلب الكلمات والتنسيق هو التالي ، ولا يوجد حاجة الى تغيير الكود ، وانما العمل يكون بإضافة الخانات في الجدول: Private Sub Form_Load() On Error GoTo err_Form_Load mySQL = "Select * From tbl_Controls_Properties" mySQL = mySQL & " WHERE Form_Name='" & Me.Name & "'" mySQL = mySQL & " AND Language='" & Forms!frm_Main!Lang & "'" Dim rst As DAO.Recordset Dim x() As String Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst iTwips = 576 '576 twips/cm , 1440 twips/inch For i = 1 To rst.RecordCount Me(rst!ctl_Name).Caption = rst!ctl_Caption Me(rst!ctl_Name).Left = rst!ctl_Left * iTwips If Len(rst!ctl_Style & "") <> 0 Then x = Split(rst!ctl_Style, "|") With Me(rst!ctl_Name) .FontName = x(0) .FontSize = x(1) .FontWeight = x(2) .FontItalic = x(3) .FontUnderline = x(4) .ForeColor = x(5) If rst!Language = "A" Then '0=General '1=Left '2=Center '3=Right '4=Distribute .TextAlign = 3 Else .TextAlign = 1 End If End With End If rst.MoveNext Next i Exit Sub err_Form_Load: If Err.Number = 438 Or Err.Number = 13 Then 'ignor, Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub وهذا الكود الذي يفتح لنا msgbox : Public Function aRemark(N) 'call the Arabic Remarks in Table tbl_Controls_Properties aRemark = DLookup("[Remark]", "tbl_Controls_Properties", "[Form_Name]='" & Me.Name & _ "' And [Language]='" & Forms!frm_Main!Lang & _ "' And [Remark_ID] = " & N) End Function هذا البرنامج برنامج بدائي ، والذي يمكن تطويره 🙂 جعفر MultiLanguage2.zip

وعليكم السلام-تفضل مشكلة الحضور قبل الموعد في الاكسيل.xlsm

اعتقد الاكسيل بمختلف مستوياته سيفيدك كثيرا اما عن المحاسبة نفسها ، لا ادري ان كان دراسة المحاسبة نفسها عن طريق التعليم المفتوح مناسبا ؟ عن نفسي لم اصادف كورسات محاسبة على النت و لكن ببحث بسيط ستجد عدة كورسات على اليو تيوب و دوريات تعلن عنها شركات اضغط هنا و لكن لم اجرب اي منها

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

صممها كما تريد على شكل نموذج .......

أحسنت استاذنا الكبير بارك الله فيك وزادك الله من فضله

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

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

وعليكم السلام-جرب هذا الرابط به تقريبا نفس موضوعك من أعمال الأستاذ الكبير سليم حاصبيا https://www.officena.net/ib/topic/92360-طلب-اضافة-ترحيل-بيانات-بملف-اكسل/

وعليكم السلام -يمكنك وضع واستخدام هذه المعادلة في الخلية N2 =IF(AND($O$2>=$L$2,$P$2>=$L$2),1,"")

وعليكم السلام-تفضل برنامج الأرشيف.xlsx

الف شكر يا باشا تم التطبيق بنجاح

تفضل لك ما طلبت-فانك لم توضح هذا من البداية Fuddruckers OD Jun 2019.xlsx

بالنسبة للسؤال الاول (المفروض ان فى رقم 2 التاريخ بدأ من 17-5-2015 والناتج طلع 40 المفروض يطلع 35) في رقم 2 البداية (سنة 2017) الأشهر هي 5 /6 / 7 / 8 / 9 / 10 /11 / 12 أي ما مجموعه 8 أشهر و ليس 7 بالنسبة للسؤال الثاني (المرفق صفحة Correction) تم العمل على ان 1- اذا كان تارخ البداية اكبر من 15 يحتسب نصف الشهر و الا الشهر كاملاً 2-اذا كان تاريخ النهاية اصغر من 15 يحتسب نصف الشهر و الا الشهر كاملاً كل هذا بواسطة المعادلات اما اذا اردت الحل بواسطة الماكرو تجد الحل في الصفحة vba_sh من نفس الملف المرفق الكود Option Explicit Sub get_Salary() Dim Annee%: Annee = [d1] Dim arr_val() Dim i%, ind%, t% Dim def1 As Double, def2 As Double Dim adrs1%, adrs2% Dim m As Double, s As Double Dim LRA%: LRA = Cells(Rows.Count, 1).End(3).Row Dim St_year%, End_year Dim cont%: cont = 1 Range("d2:Q" & LRA).ClearContents For i = 2 To LRA St_year = Year(Range("a" & i)) End_year = Year(Range("B" & i)) If Range("a" & i) > Range("B" & i) Then MsgBox "you an Error on range: " _ & Range("a" & i).Resize(, 2).Address & Chr(10) & _ "the start date < then end One" & Chr(10) & _ "please check your data and Rerun the Macro": Exit Sub If St_year = End_year Then ReDim arr_val(1 To 1) arr_val(1) = St_year Else For ind = 1 To End_year - St_year + 1 ReDim Preserve arr_val(1 To ind) arr_val(ind) = St_year + cont - 1 cont = cont + 1 Next End If '========================================= If UBound(arr_val) = 1 Then adrs1 = Rows(1).Find(arr_val).Column Select Case Day(Range("a" & i)) Case Is < 15: def1 = -0.5 Case Else: def1 = 0.5 End Select Select Case Day(Range("b" & i)) Case Is < 15: def2 = 0 Case Else: def2 = 1 End Select m = Month(Range("b" & i)) - Month(Range("a" & i)) + def1 + def2 - 1 Cells(i, adrs1) = Abs(m) * Range("c" & i) End If '========================================= '++++++++++++++++++++++++++++++++++++++++++++++ If UBound(arr_val) <> 1 Then adrs1 = Rows(1).Find(arr_val(1), lookat:=1).Column adrs2 = Rows(1).Find(arr_val(UBound(arr_val)), lookat:=1).Column Select Case Day(Range("a" & i)) Case Is < 15: m = 13 - Month(Range("a" & i)) Case Else: m = 13 - Month(Range("a" & i)) - 0.5 End Select Cells(i, adrs1) = m * Range("c" & i) '============================ Select Case Day(Range("b" & i)) Case Is < 15: m = Month(Range("b" & i)) - 0.5 Case Else: m = Month(Range("b" & i)) End Select Cells(i, adrs2) = m * Range("c" & i) For t = LBound(arr_val) + 1 To UBound(arr_val) - 1 adrs1 = Rows(1).Find(arr_val(t)).Column Cells(i, adrs1) = 12 * Range("c" & i) Next End If Erase arr_val: cont = 1 Next Columns("d:Q").AutoFit End Sub الملف مرفق Mounth_Price_new.xlsm

بعد اذن اخي بن علية ربما ينفع هذا الكود Option Explicit Sub cut_my_number_Please() Dim reg As Object Dim MY_match Dim Matches Dim i%, lr%: lr = Cells(Rows.Count, 1).End(3).Row Dim k%: k = 3 Dim c%: c = 1 Range("c1").CurrentRegion.ClearContents Set reg = CreateObject("VBscript.RegExp") With reg .Pattern = "1122" .Global = True End With For i = 1 To lr If reg.test(Range("a" & i)) Then Set Matches = reg.Execute(Range("a" & i)) For Each MY_match In Matches Cells(c, k) = MY_match k = k + 1 Next End If k = 3: c = c + 1 Next i End Sub الملف مرفق My_regex.xlsm

السلام عليكم ورحمة الله إذا فرضنا أن السريالات موجودة في العمود B بداية من الخلية B2 فتكون المعادلة في C2 (مثلا) كما يلي: بالفرنسية : =--STXT(B2;TROUVE("/";B2;1)-4;4) وبالإنجليزية : =--MID(B2;FIND("/";B2;1)-4;4) والله أعلم

عليك السلام ورحمة الله وبركاته بعد إذن أستاذنا الفاضل بن علية ممكن يكون الحل في الصورة المرفقة

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

اتفضل أخى الكريم تعديل بسيط على الكود الموجود بالملف يوضع فى حدث الضغط على الزر الموجود بالفورم سيقوم بفتح الملف الآخر Backup data الموجود بنفس المجلد الموجود به الملف الأول ( شرط اساسى ) وسيقوم بترحيل البيانات ثم حفظه وإغلاقه الكود Dim sh As Worksheet, ws As Worksheet Dim wkb As Workbook If TextBox1.Value = "" Or TextBox2.Value = "" Or ListBox1.Value = "" Or ListBox2.Value = "" Or ListBox3.Value = "" Or ListBox4.Value = "" Or ListBox5.Value = "" Then MsgBox "برجاء اكمال البيانات" Exit Sub End If '========================================================= Set wkb = Workbooks.Open(ThisWorkbook.Path & "\Backup data.xls") Set ws = Sheets("TAG CALL") ws.Activate '======================================================== LROW = Range("A" & Rows.Count).End(xlUp).Row Range("A" & LROW + 1).Value = TextBox2.Value Range("A" & LROW + 1).Offset(0, 1).Value = ListBox2.Value Range("A" & LROW + 1).Offset(0, 2).Value = ListBox4.Value Range("A" & LROW + 1).Offset(0, 3).Value = ListBox3.Value Range("A" & LROW + 1).Offset(0, 4).Value = ListBox5.Value Range("A" & LROW + 1).Offset(0, 5).Value = ListBox1.Value Range("A" & LROW + 1).Offset(0, 6).Value = TextBox1.Value TextBox1.Value = "" TextBox2.Value = "" ListBox1.Text = "" ListBox2.Text = "" ListBox3.Text = "" ListBox4.Text = "" ListBox5.Text = "" '--------------------------------- wkb.Close SaveChanges:=True

تفضل كان عليك من البداية استخدام خاصية البحث في المنتدى فهناك موضوع كبير للعلامة الراحل عماد الدين الحسامى يخص طلبك ,موجود على كل هذه الروابط https://www.officena.net/ib/topic/63602-أعمال-العلامه-القدير-الراحل-عماد-الدين-الحسامى/?tab=comments#comment-413052 https://www.officena.net/ib/topic/32270-لأول-مرة-في-الأكسل-شجرة-الحسابات-بهذه-الطريقة/page/2/?tab=comments#comment-260297 https://www.officena.net/ib/topic/56966-اريد-عمل-شجرة-حسابات-بالtree-view-فى-الاكسيل/?tab=comments#comment-361556 وأيضا هذا هو البرنامج شجرة الحسابات.xls

لا يمكن العمل على التخمين عليك برفع الملف وشرح المطلوب عليه بكل دقة

وعليكم السلام-تفضل فرز حسب الحالة - نقص صف.xls

تفضل لك ما طلبت ,تم التعديل للطلبات الجديدة مستحقات 1.xlsx

اتفضل كل شئ بالعربى >>---> التاريخ الميلادى - التاريخ الهجرى - الوقت دونما التقيد بلغة النظام المتغير (1).accdb

التعديلات التى تمت والاضافات - زر امر واحد لتسجيل الدخول / تسجيل الخروج - تحويل الاوبشن جروب الخاص بالدور الى كمبوبوكس يضفى مرونة أكثر اذا ذادت الادوار -اضاقة كمبوبوكس برقم الغرفة الان يتم من داخل النموذج الفرز والتصفية بناء على الطابق - رقم الغرفة -بأخر نموذج التسكين عدد الاسرة اجمالا وتفصيلا حسب التصفية والفرز -اخفاء اطار اكسس -توسيط النماذج -تصغير القاعدة بجوار الساعة وتغيير الايقونة كما تريد -فى حالة عدم وجود الايقونة المخصصة يتم استبدالها بايقونة الاكسس دون التقييد بنسخة الاكسس ومساره - منع الدخول الى محرر الأكواد من خلال ايقاف عمل الضغط على الأزرار Alt + F11 من لوحة المفاتيح الزبدة فى حالة فتح القاعدة عند عدم اضافة الاسرة يجبر المستخدم على اضافة الاسرة تلقائيا هى دى الزبدة لا لا لا لا لا لسة الزبدة جاية نموذج اضافة الأسرة بسهولة ومرونة بتحديد الطابق اولا قم تحديد رقم الغرفة ثم كتابة عدد الأسرة إجمالا المفترض تواجدها لهذه الغرفة ويتم لو اردت وضع 99 سرير بالغرفة دفعة واحدة الزتونه ان كانت الغرفة تحتوى على 5 اسرة واريد ان يكون مجموع الاسرة 15 يعنى نريد اضافة عدد 10 من الاسرة نكتب العدد الاجمالى 15 ههههههه نعم يضيف الفارق من الاسرة بين العدد الاجمالى الحالى والعدد الاجمالى الجديد فقط دون ادنى مشكلة مع الحفاظ على الترقيم بالالية التى وضعها معلمى الجليل واستاذى القدير و والدى الجبيب الاستاذ @ابوخليل وبهذا تم تلبية طلب اخى وحبيبى الدكتور @حلبي بعمل شاشة لاضافة اجمالى الاسرة دفعة واحدة وما سبق تعديله واضافته هو هدية منى تعديل المرفق dbskn(3).zip

في تقديري أن هذه المقطوعة من الشفرة ناقصة! وعند مراجعتي _على عجل_ للمشاركات المتعلقة بالموضوع وجدت أنها تفتقر إلى الطريقة الصحيحة للطبيق!

بارك الله فيك أستاذ محمد وجزاك الله كل خير -توكل على الله

كود ممتاز احسنت استاذ سليم جعله الله فى ميزان حسناتك واكثر الله من أمثالك

ربما كان هذا الكود اسرع بحوالي 10 مرات باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق الرجاء النظر الى هذه الملف لمعرفة ما أعنية من وجهة نظر السرعة Search_by_find_timer .xlsm

السلام عليكم ورحمة الله تعالى وبركاته ندخل فى الموضوع بالنسبة لربط قاعدة البينات اكسس باالاستضافات والتحكم فى البرنامج الخاص بك من اى مكان فى العالم شرط الاتصال بالانترنت اولا قمت بحجز استضافة مجانيه من هذا الموقع https://somee.com/ وقمت بانشاء جدول SQL للتجربة فقط بهذا البرنامج https://msdn.microsoft.com/en-us/sqlserver2014express.aspx?f=255&MSPPError=-2147217396 ونظرا لطلب الاخوة فى هذا الموضوع http://www.officena.net/ib/index.php?showtopic=61485&hl= بخصوص الربط وجعل قاعدة اكسس مجرد واجهة قمت باعداد هذا المرفق والذى يعتمد على الاكواد المذكورة فى المشاركة السابقة اما ان تنشء اتصال DNS وتستورد منه الجداول من خلال اكسس او تربط الجداول مباشرة بقاعدة اكسس وتضيف وتعدل فيها وقت ما تشاء ومن اى مكان تحب وعند اختيار ربط الجداول ستجد تلقائيا جدول فى قاعدة البيانات باسم mared تستطيع التعدل والاضافة فيه فى امكان اترككم مع المرفق انشاء اتصال DNS.rar

تفضل اضغط زر الأمر وانتظر قليلا لأن البيانات كثيرة Test--kemas.zip