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

السلام عليكم نفضل اخي الكريم تحياتي

وعليكم السلام-لك ما طلبت مستخلص كميات لسيارات النقل.xlsx

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

راجع المرفق التالي بارك الله فيك UserLog.rar تحياتي

فورم بيان موظفين مع الصور ب MultiPage الفيديو

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

جزاك الله خيرا اخي الكريم والشكر موصول لاستاذنا الفاضل @احمد الفلاحجي تحياتي

جزاك الله خيرا اخى @محمد ابوعبد الله

1-لا تجعل الخلية L1 فارغة ولا تحتوي على اسم اي شيت 2-اذا كان النطاق من L2 و نزولاً فارغاً الكود يأخذ كل الصفحات وإلا الصفحات المحددة في هذا النطاق 3-عدم ترك خلايا فارغة بين اسماء الشيتات المطلوبة في العامود L تفضل الكود المطلوب Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro% 'first found row Dim ACT_Ro% 'Actual row All Others found rows Dim m%: m = 4 Dim My_rg As Range 'find range with Criteria in cell(A2) Dim Mon_Array SH.Range("A4:F" & Rows.Count).Clear Set Principal = Sheets("serch") Mon_Array = Application.Transpose(Range("L2", Range("L1").End(4))) If UBound(Mon_Array) > Sheets.Count Then For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop Next_sh: Next Else '================================================ For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh1 If Application.CountIf(Principal.Range("L2:L50"), SH.Name) <> 0 Then Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh1 Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop End If Next_sh1: Next '==================================== End If If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:F" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف مرفق Saerch_by_Special_sheets.xlsm

في هذاه الحالة يلزم هذا الكود Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro% 'first found row Dim Ro_Atc% 'All Others found rows Dim m%: m = 4 Dim My_rg As Range 'find range with Criteria in cell(A2) SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row: Ro_Atc = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro_Atc, 1).Resize(, 5).Value m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) Ro_Atc = My_rg.Row If Ro_Atc = Ro Then Exit Do Loop End If Next_sh: Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف مرفق Search_Account _repetitions.xlsm

تفضل لك ما طلبت بمعادلة معرفة وهى Text_ALL Option Explicit Function Text_ALL(rng As Range) Dim i%, x$ With CreateObject("VbScript.RegExp") .Global = True .Pattern = "([\u0621-\u064A]+)" If Not (.Test(rng.Value)) Then _ Text_ALL = vbNullString: Exit Function For i = 0 To .Execute(rng.Value).Count - 1 x = x & " " & .Execute(rng.Value)(i).Value Next i Text_ALL = x End With End Function وهذه المعادلة توضع بالخلية B2 =Text_ALL(A2) New Microsoft Excel Worksheet.xlsm

جرب المرفق عقد ايجار2.accdb

تم معالجة الامر بالتعديل على الكود كما يلي Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro%, m%: m = 4 Dim My_rg As Range SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then Set My_rg = SH.Range("c:c").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row If Ro > 0 Then Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro, 1).Resize(, 5).Value m = m + 1 End If End If Next_sh: Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف من جديد Search_Account _new.xlsm

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

وعليكم السلام-كان عليك استخدام خاصية البحث بالمنتدى-تفضل طلب مساعدة ( جمع الأعداد دون المتكرر منها ) وهذه هى المعادلة المستخدمة =SUMPRODUCT((($D$5:$D$16<>"")/COUNTIF($D$5:$D$16,$D$5:$D$16&""))*($D$5:$D$16)) حساب الاعداد المكررة مرة واحدة 1فقط.xlsx

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

حياك الله 🙂 ومبارك لك جهودك للمضي قُدما ، بدون استسلام 🙂 انا كذلك لا الجئ الى المكتبات لنفس السبب 🙂 جعفر

تفضل لك ما طلبت هذه الأكواد فى مديول عادى Sub hide_menu() Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)" End Sub Sub show_menu() Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",True)" End Sub وهذا الكود فى حدث ThisWorkBook Private Sub Workbook_Open() hide_menu End Sub وذلك كما بالملف Hide.xlsm

للعمل بالكود يجب ام يكون الجدول مستقلاً (راس واحد دون تدخل خلايا غير فارغة على كل اطرافه) تم التعديل على تصميم الجدول في الصفحة AS بحيث يفهمه اكسل كجدول حقيقي الكود بعد تعديله Sub MY_Test() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Set ws = Sheets("DATA") Set sh = Sheets("AS") With Application .Calculation = xlCalculationManual .ScreenUpdating = True End With On Error Resume Next With sh .Range("B2:U1026").Clear ws.Range("B7:U1026").Copy .Range("B2").PasteSpecial xlPasteValues .Columns(5).Replace 0, "" .Columns(5).SpecialCells(4).EntireRow.Delete .Range("B1").CurrentRegion.Sort _ Key1:=sh.Range("E1"), Order1:=1, Header:=1 .Range("M:L").NumberFormat = "d/m/yyyy" End With On Error GoTo 0 With Application .CutCopyMode = False .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Range("B3").CurrentRegion.Borders.Value = 1 Range("B3").CurrentRegion.Offset(1).InsertIndent 1 sh.Range("B1").Select End Sub الملف مرفق Extract_sans_vide.xlsb

السلام عليكم ورحمة الله تم إضافة الكود (البسيط) التالي في كود حدث الشيت "قائمة" (لتحديث الحساب عند تحديد إحدى خلايا العمود E): Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$E$" & ActiveCell.Row Then Calculate End Sub أرجو أن يفي الغرض المطلوب... بن علية حاجي ملف اكسل.xlsm

فقط عليك استخدام هذه المعادلة =COUNTIF($B8:$AF8,$NU$5)/4 أو عن طريق معادلتك بعد القسمة على 4 لتكون بهذه الطريقة =SUMPRODUCT((OFFSET($A8,0,1,1,372)<>"")*(OFFSET($A$3,0,1,1,372))*((OFFSET($A8,0,1,1,372))=NU$5))/4 leave tracker.xlsb

وعليكم السلام-تفضل بمجرد كتابة الرقم بالعمود C سوف تظهر قيمته بالعمود B 1مثال.xlsx

في الواقع ما كنت مرتاح من المسافات بين السنوات ، وخصوصا المسافات بين الدرجات ، فتوصلت الى التالي : التقرير rpt_4 مصدر بياناته هو الاستعلام qry_4 والذي هو نسخة من qry_3 ، ولكننا ننادي وحدة نمطية تختلف قليلا عن سابقتها ، فهنا نستعمل لغة HTML : 1. الاستعلام qry_4 ، ونرسل البيانات المطلوبة الى الوحدة النمطية Year_Report_HTML . 2. وهذه هي الوحدة النمطية : Public Function Year_Report_HTML(lbl_str As String, id As Long) As String On Error GoTo err_Year_Report_HTML 'On Error Resume Next DoCmd.DeleteObject acQuery, "NewQueryDef" On Error GoTo err_Year_Report_HTML Dim rst As DAO.Recordset Dim lbl, str, mySQL As String mySQL = "Select * From qry_1 Where [Table2_id]=" & id & " Order By Table2_id desc" Set rst = CurrentDb.OpenRecordset(mySQL) Do While Not rst.EOF 'lbl = lbl & rst!Yearr & " " '2 spaces 'str = str & " " & rst!Report & " " '1 space and 8 spaces lbl = lbl & "<font color=black>" & rst!Yearr & "</font><font color=white>" & ChrW(&H2588) & ChrW(&H2588) & "</font>" str = str & "<font color=white>" & ChrW(&H2588) & "</font><font color=black>" & rst!Report & "</font><font color=white>" & ChrW(&H2588) & ChrW(&H2588) & ChrW(&H2588) & "</font>" rst.MoveNext Loop If lbl_str = "lbl" Then Year_Report_HTML = lbl Else Year_Report_HTML = str End If Exit_Year_Report_HTML: rst.Close: Set rst = Nothing Exit Function err_Year_Report_HTML: If Err.Number = 3061 Then 'too few parameters, expected 1 or more 'this error occurs when trying to run a query which needs its parameters from a Form, 'the Form should be open with the parameter, then this code take the values properly Dim qdf As QueryDef Dim prm As Parameter Set qdf = CurrentDb.CreateQueryDef("NewQueryDef", mySQL) For Each prm In qdf.Parameters prm.Value = Eval(prm.Name) Next prm Set rst = qdf.OpenRecordset(dbOpenDynaset) DoCmd.DeleteObject acQuery, "NewQueryDef" Resume Next ElseIf Err.Number = 7874 Then 'could not find QueryDef Resume Next ElseIf Err.Number = 2486 Then 'could not delete QueryDef Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function . ونلاحظ اننا نعطلي لون اسود للسنوات والدرجات ، ولكننا نعطي اللون الابيض "للمسافة" ، يعني فقط اطبع هذا التقرير على ورق ابيض ، حتى لا ترى "المسافات" : . 3. الحقلين الذين في الاستعلام ، نراهم هنا . وهذه اعدادات الحقلين حتى يأخذوا لغة HTML . والنتيجة : . جعفر 1161.tt.accdb.zip

السلام عليكم اخي العزيز الحسن لم اجد سوى هذه الطريقة حول اخفاء واظهار حقل تجميع قيمة الدفع وهي تعمل 100 % تحياتي DBdb.rar

فقط يمكنك استخدام هذه المعادلة =CEILING(C2,1) ABSS1.xls

انظر للمرفق اخي الكريم/اتمنى يكون طلبك DBdb.rar

إلى السيد hamed12345 كلمة المرور هي : 1992

أخوتي الافاضل أبدأ بإذن الله معكم في هذا الموضوع مشروعا لفتح بوابة أخزن من خلالها كل ما يسمح به وقتي من مقتطفات وتلميحات وأفكار وتطبيقات بعضها ضروري وبعضها مفيد وبعضها قد يلزم وبعضها نحتاج لفهمه عند استخدامه و منها يلزم فهمه كيما نتقن استخدامة. فهي سلسلة تتوالى فيها الافكار من هنا وهناك ، نسأل الله العون للاستمرار وندعو الله ان تعم الفائدة وتتحقق. وأنتهج هنا التبسيط والشرح والتصوير وطرح الادوات والطرق واترك لابداعاتكم استخدامها حين تلزم. وبالتشاور مع الاخوة كان الرأي أن تكون هذه المشاركة بوابة للمشاركات التي تتعلق بالفكرة وتحوي عناوين وروابط المشاركات المعنية . مع شكري وتقديري لاخوتي ابو خليل و منتصر الانسي لتشجيعهم لي ومساهماتهم الطيبة . والله من وراء القصد ﴿وَمَا أَسْأَلُكُمْ عَلَيْهِ مِنْ أَجْرٍ إِنْ أَجْرِيَ إِلَّا عَلَى رَبِّ الْعَالَمِينَ﴾ الشعراء/109. ولكنني اطمع بصالح دعائكم بظهر الغيب كيف نستخدم التقويم ( لإختيار وتحديد التاريخ ) http://www.officena.net/ib/index.php?showtopic=36090 التحكم بالوقت ( الساعة) http://www.officena.net/ib/index.php?showtopic=36110 تغيير النموذج الفرعي ضمن نموذج رئيسي http://www.officena.net/ib/index.php?showtopic=36111 إضافة "إشعار حقوق الطبع والنشر" إلى قاعدة البيانات http://www.officena.net/ib/index.php?showtopic=36112 محرك بحث http://www.officena.net/ib/index.php?showtopic=35575 تطبيق نسخة تجريبية http://www.officena.net/ib/index.php?showtopic=34558 مربعات تحرير ذكية لاختيار التاريخ http://www.officena.net/ib/index.php?showtopic=36124 سجل تجميعي أفقي Horizontal Field طلب الأخ outnet وإبداع منتصر الآنسي http://www.officena.net/ib/index.php?showtopic=36136 ترصيد الاجازات The vacations Balance http://www.officena.net/ib/index.php?showtopic=36147 بحث و تحليل في قيم مركبة لحقل طلب نارت لبزو و تطبيق منتصر الآنسي http://www.officena.net/ib/index.php?showtopic=36156 .......

نحن نفتخر بك نعلم في كل حالات عندك حل تاني شكرا لانك معنا

جرب وبفكره اعتقد سهله ... استخدمت استعلام ليغني عن الكود .. وطبعا يمكن ان تكون الفكره بكود وبداله تستدعى في النموذج بالتوفيق تلوين السجلات1.rar

الان وقت النوم غدا راح اشوف لاني عندي دوام وغدا ساتابع ان شاء الله اکید عندک شی ماعندنا کل مرة عندك حل اضافي

الله یجزیک كل خير اخي واستاذي رمهان انا مش مستحق لذلك وشكرا لك على كلامك تحياتي

الى هنا اقول وباعلى صوت حق لك ان تصبح خبير واكثر استاذ شيفان

هل تريد هكذا اتفضل تلوين السجلات.rar

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

بعض الشروط الفنية لبناء الجمل ودعونا هنا نتحدث عن بنية الجملة وبعض الشروط الفنية فيها. بنية الجملة SELECT Employees .LastName, Employees .FirstName FROM Employees WHERE (((Employees .City)=”Seattle”)); جملة تزودنا بالمعايير أما فيما يتعلق بالأقواس ، فيمكننا تركها وكتابة العبارة كما يلي : SELECT Employees.City, * FROM Employees WHERE Employees.City="Seattle"; كلمة رئيسية ترشد الاستعلام لاسترداد البيانات Employees .City, * أو قائمة الحقول التي تحدد أي الحقول سيتم إظهارها تحديد مصدر البيانات

SELECT … WHERE جملة WHERE وتصفية السجلات. يتم استخدام جملة WHERE لاستخراج ، فقط ، تلك السجلات التي تفي بمعيار محدد. بناء الجملة SQL SELECT … WHERE Syntax SELECT column_name(s) FROM table_name WHERE column_name operator value وحيث نريد تحديد الاشخاص الذين يقطنون في مدينة "" من الحقل City من الجدول Employees ، نستخدم عبارة SELECT WHERE التالية : SELECT Employees.City, * FROM Employees WHERE (((Employees.City)=”Seattle”)); ويكون شكل result-set كما في الاستعلام Q_WHERE NA_NorthwindSQL.rar

الجزء 2 سنقوم ضمن هذا الجزء بشرح تطبيقات عملية وبعض دقائق الأمور الحاسمة و المهمة ، كي نتمكن من إستخدام SQL بسهولة ويسر . ومن خلال هذا الفصل سيتم شرح وتفصيل جملة (عبارة) SELECT وتستخدم عبارة SELECT لتحديد البيانات من قاعدة بيانات ، ويتم تخزين النتيجة في جدول النتيجة، المسمى ( مجموعة النتيجة ) result-set . SELECT بناء الجملة SQL SELECT Syntax SELECT column_name(s) FROM table_name و .... SELECT * FROM table_name[/right] ومثال ذلك تعاملنا مع الجدول Employees من قاعدة البيانات المختارة للتطبيق Northwind نريد تحديد مضمون الأعمدة "LastName" و "FirstName" من الجدول Employees ، فنستخدم العبارة التالية : SELECT LastName,FirstName FROM Employees أو SELECT Employees .LastName, Employees .FirstName FROM Employees; SELECT Employees .* FROM Employees; فائدة : النجمة (*) هو وسيلة سريعة لتحديد كافة الأعمدة! ويكون شكل result-set كما كما في الاستعلام Q_SelectAll ....................................... NA_NorthwindSQL.rar ويكون شكل result-set كما في الاستعلام Q_Select SELECT * نريد تحديد كافة الأعمدة من الجدول Employees ، فنستخدم العبارة التالية : SELECT * FROM Employees أو