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

تفضل بالمعادلات Maliki_FORMULA.xlsm

جرب هذا الملف Option Explicit Sub One_by_one() Dim S As Worksheet Dim F_rg As Range Set S = Sheets("Salim") If S.Range("C2") = "" Then S.Range("C2") = 1 If S.Range("D2") = "" Then S.Range("D2") = "السبت" S.Range("B7").Resize(10, 2).ClearContents Select Case S.Range("C2") Case 1 Set F_rg = S.Range("B20:N20").Find(S.Range("D2"), lookat:=1) Case 2 Set F_rg = S.Range("B34:N34").Find(S.Range("D2"), lookat:=1) Case 3 Set F_rg = S.Range("B48:N48").Find(S.Range("D2"), lookat:=1) Case 4 Set F_rg = S.Range("B62:N62").Find(S.Range("D2"), lookat:=1) Case Else Exit Sub End Select If Not F_rg Is Nothing Then Range("B7").Resize(10, 2).Value = _ F_rg.Resize(10, 2).Value End If End Sub الملف مرفق Maliki.xlsm

بداية يجب إرجاع الفضل لإهله الاستاذ / سليم حاصبيا - الاستاذ ابراهيم الحداد فى مساعدتهم الدائمة وخاصة فى اعداد هذا البرنامج والذى اتمنى ان يحوز رضاكم كتلميذ من تلامذة المنتدى أمنيتى تعريفى بعيوبه من جانب اساتذتى واسم المستخدم/ محمد فتحى / وكلمة المرور 1970 ومحرر الاكواد / 6101970 1562309003_.rar

{ السلام عليكم ورحمة الله وبركته } كيف حالكم ان شاله بخير اليوم حبيت اشاركم كود او ملف راح يفيد مستخدمين اكسس بشكل كبير الملف المرفق في هذا الموضوع فيه ملف تجريبي هو عباره عن ملف يتم وضعه بجوار البرنامج ويحمل نفس اسم البرنامج وعند عمل اختصار لفتح البرنامج قم بوضع الاختصار علي الملف الذي وضعته بجوار البرنامج محتوا الملف كود وكل ما عليك فعله وها فتح الملف من خلال تحريره وفي مكان المخطط في الأصفر ضع اسم البرنامج مع صيغته كما موضح في الصورة بعدها اعمل اختصار لفتح هذا الملف وها بدورة راح يفتحك برنامج ولاكن بدون تشغيل خلفية اكسس وأيضا اذا كان الأمان شغال راح يلغيه فقط اذا فتحت برنامج الجود ممتاز جدا جربوه وعطني رايك طبعا الكود عطاني أيها صديقي أبو ياسين تخفيظ امان اكسس واخفاء خلفية تشغيل الاكسس.rar

السلام عليكم ورحمة الله وبركاته بعد اذن استاذنا عصام ربيع وضعت لك كود خلف زر لاستيراد البيانات من فورم الأصناف كما بالصورة اضغط علي الزر وانظر النتيجة ولا تنسانا من دعوة بظهر الغيب ملاحظات: 1- اجعل شيت الاكسل في نفس مجلد البرنامج 2- عدل اسم العمود ipage_ID في شيت الاكسل ليتناسب مع اسم العمود بالجدول ليصبح ipage فقط 3- لا تنزعج من رسالة تأكيد الاستيراد للبيانات ImportFromExcel.rar

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

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

وعليكم السلام وما هو الغرض أو الفائدة من كل هذا !!!

كلام جميل او يمكن اعتبار الموجودات الحالية عند بدء استخدام البرنامج وإدخالها كرصيد أولي

ما العمل وانت تقومين بتشكيل ملف مع صفحات غير منتظمة من حيث النتسيق في الصورة الرقم المستندى في عامود (C) في صفجة وفي عامود اخر D في صفحة اخرى لاخر مرة أقوم بالتصحيح فلا وقت للعمل يهذه الأمور (لان الكود يجب ان يبحث عن الرقم المستندى في عامود مجدد) الكود الجديد Option Explicit Sub Get_Data() Dim Arr_SH(), t% Dim Arr_Number() Dim NO_arr, n%, K% Dim x As Boolean Dim Special_SH As Worksheet Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, i% Dim F_rg As Range NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _ "تقرير5", "تقرير6", "تقرير7") Set Special_SH = Sheets("تقرير تجميعى") Application.ScreenUpdating = False K = 1 For i = 1 To Sheets.Count x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0)) If x Then ReDim Preserve Arr_SH(1 To K) ReDim Preserve Arr_Number(1 To K) Arr_SH(K) = Sheets(i).Name: Arr_Number(K) = K K = K + 1 End If Next i m = 2 Special_SH.Range("A1").CurrentRegion.Offset(1).Clear For t = LBound(Arr_SH) To UBound(Arr_SH) Set sh = Sheets(Arr_SH(t)) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 5 To ro If sh.Cells(i, 1) = vbNullString Then GoTo next_I If Application.CountA(sh.Cells(i, 4).Resize(, Col - 4)) = 0 Then GoTo next_I Special_SH.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 3).Resize(, Col - 3). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Special_SH.Cells(m, 4) .Value = F_rg '+++++++++ By choise You can insert _ ' Sheets name or Sheet Number++++++++++++ ' .Offset(, 1) = Arr_Number(t) .Offset(, 1) = sh.Name '++++++++++++++++++++++++++++++++++ ' .Offset(, 2) = sh.Cells(1, F_rg.Column) .Offset(, 3) = sh.Cells(i, 3) .Offset(, -3).Resize(, 7).Interior.ColorIndex = _ IIf(n Mod 2 = 0, 24, 36) End With m = m + 1 End If next_I: Next i Rem sh.Cells(5, 3).Resize(ro - 4, Col - 2).ClearContents n = n + 1 Next t If m > 2 Then With Special_SH.Range("A2:G" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" .Interior.ColorIndex = 40 .Value = .Value End With End With End If Application.ScreenUpdating = True End Sub Yara_New_.xlsm

شوف كده .. عملت استعلامات جديدة والنتيجة فى استعلام QryBalance استعلاماتك فيها مشكلة ومعنديش وقت اراجعها .. نصيحة قاعدة البيانات محتاجة اعادة هيكلة هتحصل معاك مشاكل بسبب التقسيم السيئ ليها. تانى حاجة نصيحة اخوية طريقة الطلب والسؤال تبقى افضل من كده لأن محدش مضطر انه يساعدك كله بيساعد على حسب وقته .. بالتوفيق ABcont Amr.mdb

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

اخر ما بمكنني عمله Option Explicit Sub Get_Data() Dim Arr_SH(), t% Dim Arr_Number() Dim NO_arr, n%, K% Dim x As Boolean Dim Special_SH As Worksheet Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, i% Dim F_rg As Range NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _ "تقرير5", "تقرير6", "تقرير7") Set Special_SH = Sheets("تقرير تجميعى") Application.ScreenUpdating = False K = 1 For i = 1 To Sheets.Count x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0)) If x Then ReDim Preserve Arr_SH(1 To K) ReDim Preserve Arr_Number(1 To K) Arr_SH(K) = Sheets(i).Name: Arr_Number(K) = K K = K + 1 End If Next i m = 2 Special_SH.Range("A1").CurrentRegion.Offset(1).Clear For t = LBound(Arr_SH) To UBound(Arr_SH) Set sh = Sheets(Arr_SH(t)) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 5 To ro If sh.Cells(i, 1) = vbNullString Then GoTo next_I If Application.CountA(sh.Cells(i, 3).Resize(, Col - 2)) = 0 Then GoTo next_I Special_SH.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Special_SH.Cells(m, 4) .Value = F_rg '+++++++++ By choise You can insert _ ' Sheets name or Sheet Number++++++++++++ ' .Offset(, 1) = Arr_Number(t) .Offset(, 1) = sh.Name '++++++++++++++++++++++++++++++++++ .Offset(, 2) = sh.Cells(1, F_rg.Column) .Offset(, -3).Resize(, 6).Interior.ColorIndex = _ IIf(n Mod 2 = 0, 24, 36) End With m = m + 1 End If next_I: Next i Rem sh.Cells(5, 3).Resize(ro - 4, Col - 2).ClearContents n = n + 1 Next t If m > 2 Then With Special_SH.Range("a2:f" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" .Interior.ColorIndex = 40 .Value = .Value End With End With End If Application.ScreenUpdating = True End Sub الملف مرفق لمسح محتويات الشيتات بعد الترحيل ازالة كلمة Rem من هذا السطر من الكود (الصورة) Yara_WITH DEL_file.xlsm

لو تفضلت اخي abouelhassan بإرسال ملف الاكسيل وبأي جدول تريد إلحاقه

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

اى طريقه قمتى بتجربتها ؟ لقد قمت بعمل الخطوات التى اشار بها اخى واستاذى ابوابراهيم الغامدى بالاعلى على 2019 وتمت بنجاح

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

السلام عليكم ورحمة الله ضع المعادلة الاولى فى الخلية J4 ثم اضغط Ctrl+Shift+ Enter ثم اسحب نزولا لآخر خلية يمكن ظهور بيانات فيها =IFERROR(INDEX($C$4:$D$20;SMALL(IF(LEFT($C$4:$C$20;LEN($H$3))=$H$3;ROW($C$4:$C$20));ROW(A1))-3;1);"") ضع المعادلة الثانية فى الخلية K4 و كرر ماسبق =IFERROR(INDEX($C$4:$D$20;SMALL(IF(LEFT($C$4:$C$20;LEN($H$3))=$H$3;ROW($C$4:$C$20));ROW(B1))-3;2);"") بحث.xlsx

الآن فقط عرفنا ايش المشكلة 🙂 الصور ، مثل البرواز وشعار المحل : اذا كانت الصورة في مجلد ، فتأكد بأن المسار نفسه موجود في الكمبيوترات ، لهذا السبب ، يُفضل بأن تحفظ الصور في مجلد داخل مجلد البرنامج ، فتشير اليه عن طريق Application.CurrentProject.Path & "\Logo_Folder\" & myLogo.jpg ، مثلا ، تأكد بأن حجم الصوره ليست كبيرة (الطول والعرض) ، فلست بحاجة الى صورة بحجم 1900x4000 فهذه الصورة تحتاج الى RAM كبير من الطابعة ، ومعظم الطابعات الرخيصة لا تملك هذه الكمية المطلوبة من RAM ، وعلى اساسها ، لا يمكنها ان تطبع الصورة. مثلا الشعار كما في صورك المرفقة ، يجب ان لا يزيد حجمه عن 500x400 مثلا. التظليل : اختار من الالوان العادية ، وقد تفيدك هذه المشاركة: جعفر

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

وعليكم السلام 🙂 جعفر

السلام عليكم ارسل لي الاخ العزيز خبور جدول بكود مختلف احب ان ارفعه اليكم ليستفيد الجميع كما استفدت منه فهو بالفعل هديه من اخ عزيز اشكره عليها كما ارسل اليكم ملف اخر تم عمله باستعمال كود الاخ خبور مع التعديلات حسب حاجتي للملف مع اضافة ميزة اخري علي جدولي السابق بان يتم تنامي الجدول ليس عند الكتابه بالخليه الاخيره للعمود الاول بل للاربع خلايا الاخيره للاربعة اعمده وهذه تعتبر اضافه جديده و مفتوح الحوار لاضافات اخري اخي العزيز ابو عبدالله رددت عليك علي اضافتك و لكني بعدما تاملتها و جدت ان ردي ليس كافيا فبالفعل اضافتك رائعة وودت ان اشكرك عليه مرة اخري لانك بالفعل تستحق ذلك و بالفعل الكود رائع بارك الله فيك اخي ashraff101 اشكرك اخي وبارك الله فيك ايضا تحياتي للجميع Khbur_.rar New_Dinamic.rar

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