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

جرب هذا الملف Option Explicit Sub get_data() Dim Inf As Worksheet Dim sh As Worksheet Dim OBJ As Object Dim S_rg As Range Dim first_row%, sec_row%, m% Dim max_ro%, Arr, ky Set OBJ = CreateObject("Scripting.Dictionary") Set Inf = Sheets("Info") max_ro = Inf.Range("B2").CurrentRegion.Rows.Count If max_ro > 2 Then Inf.Range("B2").CurrentRegion. _ Offset(2).Resize(max_ro - 2).Clear End If If Inf.Range("J1") = vbNullString Then Exit Sub For Each sh In Sheets If sh.Name <> Inf.Name Then Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1) If Not S_rg Is Nothing Then first_row = S_rg.Row: sec_row = first_row Do Arr = sh.Cells(sec_row, 3).Resize(, 6) Arr = Application.Transpose(Arr) Arr = Application.Transpose(Arr) OBJ(OBJ.Count) = Join(Arr, "*") Set S_rg = sh.Range("C:C").FindNext(S_rg) sec_row = S_rg.Row If sec_row = first_row Then Exit Do Loop End If 'find End If 'name Next 'sh m = 3 If OBJ.Count Then For Each ky In OBJ.keys With Inf.Cells(m, 3) .Resize(, 6) = Split(OBJ(ky), "*") .Offset(, -1) = m - 2 m = m + 1 End With Next With Inf.Range("B3").Resize(m - 2, 7) .Value = .Value .Columns(5).Formula = "=SUM(D3,-E3)" .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 19 .Value = .Value End With Inf.Cells(m, 2) = "المجموع" Inf.Cells(m, 4).Resize(, 3).Formula = _ "=SUM(D3:D" & m - 1 & ")" Inf.Range("B" & m).Resize(, 7). _ VerticalAlignment = 2 Inf.Cells(m, 2).Resize(, 2). _ HorizontalAlignment = 7 Inf.Range("B" & m).Resize(, 7).Value = _ Inf.Range("B" & m).Resize(, 7).Value Inf.Range("B" & m).Resize(, 7). _ Interior.ColorIndex = 35 Else MsgBox "This Name Not Exists" End If End Sub الملف مرفق Sandook.xlsm

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

جرب هذا الكود اذا لم تظهر القائمة المنسدلة (في الشيت Result) غادر الصفجة ثم عد اليها مجدداً Ihab.xlsm

قليل من التنسيق الاصافي بجيث يظهر لك مكان وجود الرصيد (اسم الشيت) مع تلوينه باللون الاصفر في الشيت Option Explicit Sub get_data() Dim Inf As Worksheet Dim sh As Worksheet Dim OBJ As Object Dim OBJ_name As Object Dim S_rg As Range Dim first_row%, sec_row%, m% Dim max_ro%, Arr, ky Dim iNCLR As Range, iNCLR_RO% Set OBJ = CreateObject("Scripting.Dictionary") Set OBJ_name = CreateObject("Scripting.Dictionary") Set Inf = Sheets("Info") '+++++++++++++++++++++++++++++ For Each sh In Sheets If sh.Name <> Inf.Name Then Set iNCLR = sh.Range("B2").CurrentRegion iNCLR_RO = iNCLR.Rows.Count If iNCLR_RO > 2 Then iNCLR.Offset(2).Resize(iNCLR_RO - 2). _ Interior.ColorIndex = xlNone End If End If Next '++++++++++++++++++++++++++++++++ max_ro = Inf.Range("B2").CurrentRegion.Rows.Count If max_ro > 2 Then Inf.Range("B2").CurrentRegion. _ Offset(2).Resize(max_ro - 2).Clear End If If Inf.Range("J1") = vbNullString Then Exit Sub For Each sh In Sheets If sh.Name <> Inf.Name Then Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1) If Not S_rg Is Nothing Then first_row = S_rg.Row: sec_row = first_row Do sh.Cells(sec_row, 2).Resize(, 7) _ .Interior.ColorIndex = 6 Arr = sh.Cells(sec_row, 3).Resize(, 6) Arr = Application.Transpose(Arr) Arr = Application.Transpose(Arr) OBJ(OBJ.Count) = Join(Arr, "*") OBJ_name(OBJ_name.Count) = sh.Name Set S_rg = sh.Range("C:C").FindNext(S_rg) sec_row = S_rg.Row If sec_row = first_row Then Exit Do Loop End If 'find End If 'name Next 'sh m = 3 If OBJ.Count Then For Each ky In OBJ.keys With Inf.Cells(m, 3) .Resize(, 6) = Split(OBJ(ky), "*") .Offset(, -1) = m - 2 .Offset(, 6) = OBJ_name.Item(m - 3) m = m + 1 End With Next With Inf.Range("B3").Resize(m - 2, 8) .Value = .Value .Columns(5).Formula = "=SUM(D3,-E3)" .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 19 .Value = .Value End With Inf.Cells(m, 2) = "المجموع" Inf.Cells(m, 4).Resize(, 3).Formula = _ "=SUM(D3:D" & m - 1 & ")" Inf.Range("B" & m).Resize(, 7). _ VerticalAlignment = 2 Inf.Cells(m, 2).Resize(, 2). _ HorizontalAlignment = 7 With Inf.Range("B" & m).Resize(, 8) .Value = .Value .Interior.ColorIndex = 35 End With Else MsgBox "This Name Not Exists" End If End Sub الملف من جديد Sandook_NEW.xlsm

بعد رفع الملف فك الضغط واحفظ المجلد في اي فولدر ثم جربه myDOS.rar

السلام عليكم ورحمة الله وبركاته استدعاء .. في البداية .. قم بعمل فولدر جديد في C .. وسميه AllCycle >> وقم بحفظ ملف new .. الذي فيه بيانات داخل الفولدر .. افتح ملف mynewreport .. وقم باستدعاء البيانات .. تم وضع الزر في الورقة 1 new.xlsx Copy of My_New_Repport.xlsm

لا يمكن للمعادلات التلاعب بالخلايا والصفوف من حيث التنسيق او الاحفاء او تغيير الخط او اي شيء اخر هذه الاشياء يفعلها الماكرو كما في هذا الملف Option Explicit Sub get_data() Dim Y As Worksheet, A As Worksheet Dim Ry As Range, Ra As Range Dim cret$, ro% Set Y = Sheets("Youmia") Set A = Sheets("Account") Set Ry = Y.Range("A7").CurrentRegion Set Ra = A.Range("A6").CurrentRegion Ra.Clear cret = A.Range("C2") If cret = "" Then cret = "إيهاب أبو سريع" A.Range("C2") = cret Ry.AutoFilter 7, cret On Error GoTo end_me Ry.Columns(1).Resize(, 3).SpecialCells(12).Copy A.Range("B6").PasteSpecial (12) Ry.Columns(28).Resize(, 2).SpecialCells(12).Copy A.Range("E6").PasteSpecial (12) ro = A.Range("A6").CurrentRegion.Rows.Count If ro > 1 Then A.Cells(ro + 6, 1) = "المجموع" A.Cells(ro + 6, 5).Resize(, 2).Formula = _ "=SUM(E6:E" & ro + 5 & ")" A.Cells(6, 7).Resize(ro + 1).Formula = "=SUM(-E6,F6)" A.Cells(6, 1).Resize(ro) = Evaluate("row(1:" & ro & ")") With A.Range("A6").CurrentRegion.SpecialCells(12) .Interior.ColorIndex = 19 .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Value = .Value .Cells(1, 1).Select End With A.Cells(ro + 6, 1).Resize(, 4).HorizontalAlignment = 7 Y.PageSetup.PrintArea = Y.Range("A1:G" & ro + 6).Address End If end_me: Y.AutoFilterMode = False Application.CutCopyMode = False End Sub الملف مرفق samia.xlsm

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

السلام عليكم 🙂 علشان نحصل على الرصيد التراكمي ، نستعمل هذا الكود في الاستعلام (ويجب ان يكون التاريخ تصاعدي) : B: CCur(Nz(DSum("[Credit]-[Debit]","[TransactionS]","[SupplierID]=" & [TransactionS].[SupplierID] & " And [Date]<=#" & [Date] & "#"),0)) . . والنتيجة . وفي الاستعلام النموذج ، تم حذف الحقل RecNo ، واستعملنا الحقل B (من الاستعلام) في حقل الرصيد ، فكانت النتيجة : . 1307.يومية مورد.accdb.zip

تم معالجة الأمر (لا يمكن العمل بدون ماكرو) samia_NEW.xlsm

تفضلي إليك ملف لتجربة الكود على تنفيذ الأمر بعد وضع كلمة المرور على هيئة نجوم كلمة المرور هي ( 123 ) ماكرو1.xlsm

وهنا تم اضافة كود استعلام بين تاريخين Sub Renseignements() Dim ws As Worksheet Dim sh As Worksheet Dim rng1, rng2 As Date Dim lr1, lr2 As Long Dim x As Long Set ws = Sheets("TAKRIR") rng1 = ws.[c2]: rng2 = ws.[d2] Application.ScreenUpdating = False lr1 = ws.Cells(Rows.Count, 1).End(3).Row + 1 ws.Range("a5:m" & lr1).ClearContents For Each sh In Sheets If sh.Name <> "Tarheel" And sh.Name <> "TAKRIR" Then lr2 = sh.Cells(Rows.Count, 1).End(3).Row For x = 3 To lr2 lr1 = ws.Range("a" & Rows.Count).End(xlUp).Row + 1 Select Case sh.Cells(x, 1).Value2: Case rng1 To rng2 ws.Range("a" & lr1).Value = sh.Name ws.Range("a" & lr1).Offset(, 1).Resize(1, 14).Value = sh.Cells(x, "b").Resize(1, 14).Value End Select Next x End If Next sh Application.ScreenUpdating = True End Sub ترحيل مدين ودائن.xlsb

إنا لله وإنا إليه راجعون. نسأل الله له الرحمة والمغفرة، اللهم وسع مدخله و اكرم نزله وآنس وحشته. عظم الله أجركم وأحسن عزاءكم.

السلام عليكم ملاحظة تم تعديل الجدول في الصفحات هذا الكود للترحيل معمول بالحلقات التكرارية ولكن فعاليته جيدة واتمنى ان يفي بالغرض Sub envoier() Dim ws As Worksheet Dim sh As Worksheet Dim rng1, rng2 As Range Dim lr1, lr2 As Long Dim x, x2, S As Long Set ws = Sheets("Tarheel") Set rng1 = ws.[e1]: Set rng2 = ws.[f1] Application.ScreenUpdating = False lr1 = ws.Cells(Rows.Count, 4).End(3).Row If lr1 = 2 Then Exit Sub For S = 3 To lr1 For Each sh In Sheets If sh.Name <> "Tarheel" And sh.Name <> "TAKRIR" Then If ws.Cells(S, 4) = sh.Name Then For x = 4 To 15 If sh.Cells(1, x) = rng1 Then lr2 = sh.Cells(Rows.Count, 1).End(3).Row + 1 ' sh.Activate sh.Range("a" & lr2).Resize(, 2).Value = ws.Range("a2").Resize(, 2).Value sh.Range("c" & lr2).Value = ws.Cells(S, "c").Value sh.Range("a" & lr2).Offset(, x - 1).Resize(, 2).Value = _ ws.Cells(S, "e").Resize(, 2).Value End If Next x End If End If Next sh Next S If MsgBox("هل تريد افراغ البيانات في الشيت", vbExclamation + vbYesNo) = vbYes Then ws.Range("c3:f" & lr1).Select End If Application.ScreenUpdating = True End Sub ترحيل مدين ودائن.xlsb

الملف غير واضح والمطلوب غير واضح لكني اجتهدت بكتابة معادلة، لعلها تكون هي المطلوبة راجع المرفق الملف.xlsx

السلام عليكم تاريخ الصرف فى الجدول الاول ( الارصدة ) امام كل كمية مصروفة مثال : كمية الصنف RM100= 110 بيان الصرف : 50 بتاريخ 14/6/2020 & 60 بتاريخ 23/8/2020 وعموما لو تقصد شىء اخر انا تحت امرك هل المرفق يفى بالغرض . ارجو الافادة حركة مخزن (1).xlsx

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

اخى noxchi.2003 يمكنك ضبط صيغة التاريخ من خلال format cell وحيث ان هذه اول مشاركة لك فلا بد من ارفاق ملف لتوضيح المطلوب به فى المشاركات القادمة

البقاء والدوام لله اللهم اغفر له واجعل مثواه الجنة واجعل قبره روضة من رياض الجنان واجعله من منزلة المرسلين والشهداء اللهم الهم اهله وذويه الصبر والسلوان

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

لا حول ولا قوة إلا بالله العلي العظيم أحسن الله لكم العزاء ، ولا اركم الله مكروها فيمن تحبون وفد على رب غفور ورسول كريم هم السابقون ونحن اللاحقون إنا لله وإنا اليه راجعون

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

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

تفضل-يمكنك استخدام هذه المعادلة =IFERROR(IF(COUNTIF($B$4:B4,B4)=1,U4&VLOOKUP($B4,$U$1:$V$2,2,0),U4&VLOOKUP($B4,$U$1:$V$2,2,0)+(COUNTIF($B$4:B4,B4)-1)),"") ترقيم وتسلسل.xlsx

بعد البحث عن سبب المشكلة التي ظهرت لدي وبعد تنبيهي من أخي أبي جودي هنا ظهر معي الخلل بهذا الكود المستخدم في فتح البرنامج With accessApp .Visible = True .UserControl = True .RunCommand acCmdAppMaximize DoCmd.RunCommand acCmdAppMaximize Set db = .DBEngine.OpenDatabase(strPathAppDB, False, False, ";PWD=" & strPasswordDB) .OpenCurrentDatabase strPathAppDB End With وقد قمت بتعديل الكود بهذا الشكل وانتهت المشكلة بفضل الله تعلي With accessApp .Visible = True .UserControl = True .RunCommand acCmdAppMaximize .OpenCurrentDatabase strPathAppDB, False, strPasswordDB End With وجزاكم الله عنا خيرا

يجب ان يكون هناك القليل من البيانات في الجدول لمعرفة كيفية عمل المعادلات تم اضافة بيانات عشوائية جرب هذا الملف samia.xlsx

تفضل تم اصلاح الخلل الان يعمل بدون اي مشاكل البرنامج الجديد 2021 (1) (12).xlsm

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

ممكن عمل هذا الكود في الاستعلام ، ولكنك وبسبب اللغة العربية في الكود ، فلن تعرف ان تغير شيء لاحقا ، لهذا السبب ، الافضل عمل وحدة نمطية ، ويمكنك تعديلها بكل بساطة ، اسميتها qry_values ، ونرسل لها قيمة الحقل من الاستعلام (في المثال السابق ، اسم الحقل كان 2020 ) ، وفي الوحدة النمطية تسمية هذا المتغير هو H : Public Function qry_values(H As Integer) As String If H = 0 Or Len(H & "") = 0 Then ' Zero and Null qry_values = "لا يوجد" ElseIf H = 7 Then ' any other value qry_values = "تم الانتهاء" Else ' return the original value qry_values = H End If End Function . ثم نناديها من الاستعلام ، هكذا : . والنتيجة : جعفر 1306.مثال.accdb.zip

وعليكم السلام ... اجعل معادلة التأخر هكذا =SUMPRODUCT(--(Sheet1!$B$2:$B$940=$B2),--(Sheet1!$G$2:$G$940<>"")) ومعادلة الباكر كذلك =SUMPRODUCT(--(Sheet1!$B$2:$B$940=$B2),--(Sheet1!$H$2:$H$940<>"")) help count late1.xlsx

بالاضافة الى ما تفضل به استاذنا jjafferr وله الشكر اخي الكريم استخدم + بديلا عن And كالتالي saves: (Nz(DSum("save";"tabl1";"code=" & [code]);0))+(Nz(DSum("ahmed";"tabl1";"code=" & [code]);0)) AA1.rar تحياتي

ريتاج المدينة لم افهم شئ -- مذا تقصد بالملف الاصلي --- وما هو الشيئ المراد ادراجة -- واين يتم ادراجه من فضلك وضح

بعد ادن الاستاد خيماوي كووول جرب المرفق ادخل رقم الشيت في العمود B ثم عدد مرات النسخ الى جانبه بالعمود A ثم انقر زر Entre لوحة المفاتيح كود عادي في حدث change اتمنى ان يفي بالغرض 1.xlsm

السلام عليكم ورحمة الله وبركاته هل تقصد بشكل هذا .. تم ارفاق عدد 2 1 - يجب ان تحدد عدد الصفوف 2 - يقوم بقراءة عدد الصفوف المراد اضافتهم حسب عدد الموجود في الخلية a7 1.xlsm 2.xlsm

عند الإضاقة قي عمود <<القسم / التوجيه>> فقط أنشى صفحات بنفس الأسماء المضاقة

ممكن اوي Option Explicit Dim Ro%, i%, J%, x%, y% Dim Rg As Range, Cel As Range '+++++++++++++++++++ Sub No_merge() If ActiveSheet.Name <> "Salim" Then GoTo Fin With Range("A1").CurrentRegion For Each Cel In .Cells If Cel.MergeCells Then x = Cel.MergeArea.Rows.Count y = Cel.MergeArea.Columns.Count Cel.UnMerge Cel.Resize(x, y) = Cel.Cells(1, 1).Value End If Next .Borders.LineStyle = 1 End With Fin: End Sub '+++++++++++++++++++++++++++++++ Sub Merge_Please() If ActiveSheet.Name <> "Salim" Then GoTo Fin Application.DisplayAlerts = False x = Range("A1").CurrentRegion.Rows.Count y = Range("A1").CurrentRegion.Columns.Count For J = 1 To x For i = 1 To y If Cells(J, i) = Cells(J, i + 1) And Cells(J, i) <> "" _ And Cells(J, i + 1) <> "" Then Range(Cells(J, i), Cells(J, i + 1)).Merge End If Next Next Fin: Application.DisplayAlerts = True End Sub الملف مرفق bachiri_MERGE_Unmerge.xlsm

1- اي نعديلات على الجدول يجب ادراجها في النطاق AA1:AG16 لأن الماكرو يأخذ البيانات من هناك بالنسبة للـــ UNMERGE جرب هذا الماكرو (الصفحة SALIM من هذا الملف ) Option Explicit Sub Mreg_equal_cells() Dim Ro%, i%, k%, t%, n%, ky Dim d As Object Dim Rg As Range Set d = CreateObject("Scripting.Dictionary") Ro = Cells(Rows.Count, 1).End(3).Row For t = 2 To 7 k = 1 Do Until k > Ro i = k: n = 1 Do Until Cells(i, t) <> Cells(i + 1, t) n = n + 1 i = i + 1 Loop Set Rg = Cells(k, t).Resize(n) d(Rg.Address) = "" k = k + n Loop Application.DisplayAlerts = False For Each ky In d.keys Range(ky).Merge Next Application.DisplayAlerts = True d.RemoveAll Next Application.DisplayAlerts = True End Sub '+++++++++++++++++++ Sub No_merge() Range("AA1:AG16").Copy Range("A1") End Sub الملف مرفق الصفحة SALIM bachiri401_MERGE.xlsm

أخواني الكرام السلام عليكم ورحمة الله وبركاته أرغب في عمل برنامج خاصة بعمل تقويم الأداء الوظيفي للموظفين حسب الآتي : 1- يتم عمل التقييم للأداء الوظيفي للموظف 3 مرات في السنة ( ثلاث فترات ) 2- يوجد ثلاث أنواع من الموظفين ( موظف ، عامل ، مشرف ) ولكل موظف بنود تختلف عن الأخر في عملية التقييم. 3- البيانات المطلوب أدخالها هي : بيانات الجهة ، بيانات الموظف ، بيانات العام ، بيانات الفترة (الأولى ، الثانية ، الثالثة ) ، بيانات عناصر التقييم . 4- في نهاية السنة أي بعد التقييم الثالث يعطي تقييم نهائي بالمتوسط لكل موظف . 5- وبعض الاستعلامات باسم الموظف ، بالتخصص ، ... وغيره 6- يعمل عملية طرح ليوضح سنوات الخبرة وذلك بين التاريخ الحالي وتاريخ التعيين ؟ 7- وطباعة بعض التقارير المطلوبة . علما بأن تم عمل بعض الجداول ولكن لم استطع ربطها بشكل صحيح ( مرفق ) فأمل من جميع الأخوة المساعدة ولكم الشكر والتقدير مقدما وحتى لو جزء بسيط من البرنامج وأنا أكمل الباقي . برنامج تقويم الأداء الوظيفي.rar

هذا البطى يرجع الى كثرة المعادلات والصيغ الموجودة فى الشيت ومهما حاولت سيكون هناك بطىء واظن ان لديك معادلات صفيف او array مثل معادلات البحث VLOOKUP و INDEX و SUMPRODUCT فسيكون الحل ان شاء الله كالتالى قم بوقف عملية الحساب واجعلها يدوى كما فى الصوره وبعد الانتهاء من كل عملك اضغط f9 وسيتم حساب الورقه وحساب المعادلات New Bitmap Image.bmp

اخي الكريم عليك عمل معادلة Subtotal ليس Sum ليتغير الاجمالي كلما تغير الفرز وتكون بهذا الشكل