محمد هشام.

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

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

العفو استاد فوزي.

اخي المعادلة تشتغل بدون ادنى مشكلة تفضل شوف https://streamable.com/tq4otn زيادة اخي الفاضل المعادلة باللغة الفرنسية ربما لا تشتغل معك عند كتابتها لان الاكسيل لن يتعرف عليها حاول تحميل الملف من المرفقات

العفو اخي واي اضافة لا تتردد في دكرها بالتوفيق

تفضل اخي السن.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته. تفضل اخي سعد يكفي وضع الملف في نفس مسار الملفات المطلوب دمجها وتحديد اسم الملف الهدف داخل الكود Sub Importer_Sheets() Dim chemin$, dossier, fichier, MH As Worksheet, lig&, i%, h& chemin = ThisWorkbook.Path & "\" dossier = Array("test-01", "test-02", "test-03", "test-04", "test-05", "test-06", "test-07") 'تحديد اسماء الفولدرات fichier = "Test.xls" 'اسم الملف الهدف Set MH = ActiveSheet lig = 4 ' تحديد اول صف يتم وضع عليه البيانات Application.ScreenUpdating = False MH.Rows(lig & ":" & MH.Rows.Count).Delete For i = 0 To UBound(dossier) With Workbooks.Open(chemin & dossier(i) & "\" & fichier).Sheets(1) 'فتح الملف If .FilterMode Then .ShowAllData 'إذا تم تصفية الورقة h = .Range("B" & .Rows.Count).End(xlUp).Row ' الى غاية الصف الأخير في العمود B .Rows("1:" & h).Copy MH.Cells(lig, 1) 'نسخ ولصق lig = lig + h + 3 '3 عدد الصفوف بين كل ورقة عمل .Parent.Close False 'اغلاق الملف End With Next End Sub بالتوفيق Test_دمج.zip

تفضل اخي لاكن حاول دائما التحقق من تطابق تنسيق عمود التاريخ في شيت البصمة وشيت Input =SIERREUR(INDEX('مواعيد البصمه'!$F$3:F200;EQUIV(1;INDEX((C6='مواعيد البصمه'!$D$3:D200)*($A$6='مواعيد البصمه'!$A$3:A200);0;1);0)); "") Payroll123-3-2020 - Copy.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي سيتم اضافة المعادلات للصف تلقائيا عند الكتابة في عمود المسلسل مع افراغها تلقائيا عند حدفه Sub Fill_the_first_cell() Dim lr As Long Dim rng As Range Set WS = Sheet2 Dim y As Integer Application.ScreenUpdating = False MH = WS.Range("A" & Rows.Count).End(xlUp).Row With Sheet2 For y = 8 To MH Cells(y, "C").Formula = "=IFERROR(VLOOKUP(B8,data!F:G,2,0),"""")" Cells(y, "F").Formula = "=IF(RC[-1]="""","""",RC[-1]*data!R3C[-4])" Cells(y, "H").Formula = "=IF(F8="""","""",G8-F8)" Cells(y, "K").Formula = "=IFERROR(IF(RC[-1]="""","""",RC[-3]/(7850*RC[-2]*RC[-1])),"""")" Cells(y, "N").Formula = "=IFERROR(IF(RC[-2]="""","""",ROUNDDOWN((RC[-3]/RC[-2])*1000,0)),"""")" Next y End With End Sub وهدا في حدث شيت (in) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 8 Then Exit Sub If Not Intersect(Target, Range("A:A")) Is Nothing Then If Cells(Target.Row, "A").Value = "" Then Cells(Target.Row, "B").Resize(, 13).ClearContents Else Call Fill_the_first_cell End If End If End Sub تشغيل الصاج-1.xlsm

تفضل اخي جرب ضع هده المعادلة لجلب القيم من عمود التاريخ =SIERREUR(SI(حسابات_الافراد!B7<>"";INDEX(حسابات_الافراد!$B$7:$B$205;EQUIV(0;NB.SI($B$6:B6;حسابات_الافراد!$B$7:$B$205);0));"");"") وهده لجلب بيانات الجدول بشرط العمود الاول مع مراعات استبدال ارقام الاعمدة داخل المعادلة =SIERREUR(RECHERCHEV($B7;INDIRECT($A$1&"!$B$7:$f$100");2;0);"") نموذج عن رحلة.xlsx

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

أولا آسف على التاخير بسبب ضيق الوقت. تفضل اخي تم تعديل الكود مع مراعات عدم وجود الغياب في إحدى المواد أو عدم وجود صف بالكامل Public Sub Filtre_de_classe() Dim sh1 As Worksheet, sh2 As Worksheet Dim Lr As Long, i As Long Dim Rng As Range Dim Arr As Variant Set sh1 = ThisWorkbook.Worksheets("غياب لجان") Set sh2 = ThisWorkbook.Worksheets("غياب إجمالي") XRng = sh1.Range("D8") Application.ScreenUpdating = False sh1.Activate ' التحقق من وجود بيانات في جدول غياب لجان Arr = Array([A11], [B11], [C11], [D11]) For i = 0 To 3 If Arr(i) = "" Then MsgBox (" لا يوجد تلاميد غائبين في مادة : " & XRng) Arr(i).Select sh2.Activate Exit Sub End If Next sh2.Range("A12:G1000").ClearContents With sh1 Set Rng = .Range("B5:D" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With With Rng With Rng Dim cntCrit As Long ' التحقق من وجود غياب في الفصل 4 cntCrit = WorksheetFunction.CountIfs(Rng.Columns(1), "الرابع") If cntCrit <> 0 Then .AutoFilter Field:=1, Criteria1:="الرابع" Lr = sh2.Range("B" & Rows.Count).End(3).Row + 1 .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("B" & Lr) End If End With With Rng '5 التحقق من وجود غياب في الفصل cntCrit = WorksheetFunction.CountIfs(Rng.Columns(1), "الخامس") If cntCrit <> 0 Then .AutoFilter Field:=1, Criteria1:="الخامس" Lr = sh2.Range("F" & Rows.Count).End(3).Row + 1 .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("F" & Lr) End If End With .Parent.AutoFilterMode = False End With sh2.Activate Application.ScreenUpdating = True End Sub أما بالنسبة لملئ الإستمارة بشرط اسم التلميذ في الخلية (C8) يمكنك إستخدام الكود التالي : Sub Récupérer_des_données() Dim sh As Worksheet Dim Lr As Long Dim Rng1 As Range Set sh1 = ThisWorkbook.Worksheets("استمارة غياب") Set sh2 = ThisWorkbook.Worksheets("غياب لجان") Lr = sh2.Cells(sh2.Rows.Count, 3).End(xlUp).Row Set Rng1 = sh1.Range("H8,H10,H12,C10,C12,C14") Rng2 = sh1.Range("C8") Application.ScreenUpdating = False With sh2 Set Trouve = .Range("C:C").Find(what:=Rng2, LookIn:=xlValues, lookat:=xlWhole) If Trouve Is Nothing Then MsgBox "اسم التلـميذ غير موجود في القائمة", Exclamation, "غياب لجان" Rng1.Select Selection.ClearContents Range("C8").Select Exit Sub Else End If If Len(Range("C8").Value) = 0 Then MsgBox "المرجوا إدخال إسم التلـميذ", Exclamation, "استمارة غياب" Exit Sub End If sh2.Activate For i = 11 To Lr If sh2.Cells(i, 3).Value = Rng2 Then sh1.Range("H12").Value = Range("A" & i).Value sh1.Range("C12").Value = Range("B" & i).Value sh1.Range("C10").Value = Range("D" & i).Value sh1.Range("H8").Value = sh2.Range("F8").Value sh1.Range("C14").Value = sh2.Range("F8").Value sh1.Range("H10").Value = sh2.Range("D8").Value End If Next i End With sh1.Activate Application.ScreenUpdating = True End Sub ملاحظة: قد تم حذف غياب اللغة العربية للتجربة بالتوفيق ............ استدعاء الغائبين_3.xls

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

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

تفضل اخي ده كود شيت غياب اجمالي لترحيل اسماء التلاميد الغائبين ورقم الجلوس وان شاء الله سوف احاول رفع الكود الثاني في المساء بادن الله Public Sub TEST2() Dim sh1 As Worksheet, sh2 As Worksheet Dim Rng As Range Dim lr As Long, lr2 As Long Set sh1 = ThisWorkbook.Worksheets("غياب لجان") Set sh2 = ThisWorkbook.Worksheets("غياب إجمالي") Application.ScreenUpdating = False 'في حالة الرغبة بالاحتفاظ بالبيانات القديمة قم بالغاء تفعيل هدا السطر من الكود sh2.Range("A12:G100").ClearContents With sh1 Set Rng = .Range("b5:d" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With With Rng .AutoFilter Field:=1, Criteria1:="الرابع" lr = sh2.Range("B" & Rows.Count).End(3).Row + 1 .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("B" & lr) .AutoFilter Field:=1, Criteria1:="الخامس" lr = sh2.Range("F" & Rows.Count).End(3).Row + 1 .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("F" & lr) .Parent.AutoFilterMode = False End With Application.ScreenUpdating = True End Sub

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

نعم يتضمن الكود ................ يمكنك نسخ الكود من المشاركة فوق ووضعها في حدث الشيت المراد التجربة عليه فعلا انا مستغرب لعدم اشتغال الملف لديك ربما احد الاخوة الاعضاء يقوم بالتجربة ويوافينا بالنتيجة

الملف يشتغل عندي بكفاءة اخي الكريم . https://streamable.com/3mbrm0 تم اعادة رفع الملف مرة اخرى للتجربة فكرة 2.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته تقضل استاد فوزي ربما هدا ما تقصد Const MyWidth As Single = 80 Const MyHight As Single = 20 Private Sub TEST1() Dim WS As Range Dim Lf As Double, Tp As Double Dim ContColmn As Integer, r As Integer, c As Integer Set WS = Range("A3:I17") ContColmn = WS.Columns.Count For r = 1 To WS.Rows.Count l = 0 Lf = Me.Frame1.Width - 100 For c = 1 To ContColmn Lf = Lf - WS.Columns(c).Width With Me.Frame1.Controls.Add("Forms.Label.1") .BorderStyle = 1 .Move Lf, Tp, MyWidth, MyHight .Width = WS.Columns(c).Width Call TEST(.Name, WS.Cells(r, c)) End With Next Tp = Tp + MyHight c = 0 Next Set X = Nothing End Sub Private Sub TEST(iName As String, MyCel As Range) With Me.Controls(iName) .BackColor = MyCel.Interior.Color .Caption = MyCel.Text .TextAlign = 2 With .Font .Name = MyCel.Font.Name .Bold = True .Size = MyCel.Font.Size End With End With End Sub Private Sub UserForm_Initialize() Me.Frame1.SpecialEffect = 0 TEST1 End Sub عرض النتائج فى الفورم_1.xlsm

تفضل اخي تم تعويض زر اظهار الفورم بدوبل كليك على الصف الأول (عناوين الأعمدة) مع امكانية اضافة صورة حتى لو البيانات غير مكتملة. طلب وتعديل4.xlsm

وفي حالة وضع شرط لو الخلية فارغة يمكنك جعل الكود كالتالي With ws.Range("c2:c" & LR) .Formula = "=IF(B2="""","""",VLOOKUP(""*""&B2&""*"",sheet1!A:E,1,0))" .Value = .Value

تفضل اخي هذا مثال لطلبك Sub TEST_mh5() Dim ws As Worksheet Dim LR As Long Set ws = Worksheets("sheet2") Application.ScreenUpdating = False LR = ws.Range("B" & Rows.Count).End(xlUp).Row With ws.Range("c2:c" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,1,0)" .Value = .Value With ws.Range("d2:d" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,2,0)" .Value = .Value With ws.Range("E2:E" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,3,0)" .Value = .Value With ws.Range("F2:F" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,4,0)" .Value = .Value With ws.Range("G2:G" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,5,0)" .Value = .Value End With End With End With End With End With End Sub جلب البيانات 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته كنت في انتظار رفع ملف للتطبيق عليه . بما انها مجرد فكرة وتريد حلها تفضل اخي الكريم يمكنك فعل دالك بواسطة الكود التالي لاستخراج مجموع القيم السالبة والموجبة وكدالك مجموع القيم المدخلة مع اضافة امكانية ظبط قيمة التغيير التي نعتمد عليها في الحساب في مثالنا هدا قد تم تنفيد طلبك مثلا اقول اذا كان التغيير هو 3 نقاط فا اكثر نبداء بالحساب ولكن اذا اكان التغيير اقل من 3 نقاط تجاهل الموضوع، وكان شيئا لم يحدث . ويمكنك ظبط القيمة كما تشاء من داخل الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$E$2" Then ' هنا ممكن ضبط قيمة اقل تغيير نعتمد عليه في الحساب' If Abs(Tmp - Target) < 3 Then Exit Sub Application.EnableEvents = False If Target < Tmp Then [m2] = [m2] + Tmp - Target 'عدد الاختلافات بالسالب' Else If Tmp <> 0 Then [g2] = [g2] + Target - Tmp 'عدد الاختلافات بالموجب End If Tmp = Target Application.EnableEvents = True End If If Target.Address = "$E$2" Then [b2] = [b2] + Target 'مجموع القيم المدخلة End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$E$2" Then Tmp = Target End Sub في حالة عدم الرغبة في وضع شرط اقل قيمة يمكنك استخدام الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = Me.[e2].Address Then Ecart = Target.Value - Me.[OldVal] Me.Names("OldVal").RefersTo = 0 + Target.Value Range("E2").Select Select Case Ecart Case Is > 0 Me.[g2] = Me.[g2] + Ecart Case Is < 0 Me.[m2] = Me.[m2] - Ecart Case 0 Range("b2").Value = Range("b2").Value + Target.Value End Select End If If Target.Address = "$E$2" Then [b2] = [b2] + Target End If End Sub واليك اخي الكريم الملف تم تطبيق الفكرة عليه للتجربة فكرة.xlsm

العفو اخي الكريم .بالتوفيق