محمد هشام.

لاكن اخي الورقة 1 لا تتضمن أسماء الموظفين .

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي للبحث برؤوس الاعمدة وجلب بيانات العمود يمكنك استخدام المعادلة التالية مع سحب المعادلة للاسفل على حسب قدر البيانات عندك في ورقة 1 =IFERROR(INDEX('الورقة 1'!A6:AC6;XMATCH($P$3;'الورقة 1'!$A$4:$AC$4;0));"") اسماء المحافظات والمدن.en.ar (2).xlsx

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

اخي هل هناك ملف اخر غير الدي قمت بارفاقه في المشاركة تريد تنفيد الامر عليه بعد اضافة الكود قم بحفظ الملف بصيغة الماكرو

أخي الكريم الكود ستجد شرح طريقة العمل في الرابط التالي https://streamable.com/3qn2ug

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub Worksheet_Activate() Set ws = Sheet1 StartRow = 7 'اول صف EndRow = 34 ' اخر صف ColNum = 2 'رقم عمود الشرط Application.ScreenUpdating = False 'بما انني لاحظت انك واضع حماية للشيت قمنا باضافة فك الحماية لتنفيد الكود ثم ارجاعها Sheet2.Unprotect ' في حالة قمت بالغاءها قم بالغاء تفعيل هدا السطر For i = StartRow To EndRow If ws.Cells(i, ColNum).Value = "" Then Cells(i, ColNum).EntireRow.Hidden = True Else Cells(i, ColNum).EntireRow.Hidden = False End If Next i Sheet2.Protect ' وهنا Application.ScreenUpdating = True End Sub بكج الافراد.xlsm

تفضل اخي جرب هل هدا ما تقصد Book2.xlsx

اخي اسف ليس لدي الوقت لشرح المعادلة يمكنك البحث في الانترنيت فهو متوفر في عدة اماكن بالصوت والصورة تفضل اخي تم اعادة تعديل الملف وتنسيقه مع تعديل بسيط داخل هدا الجزء من الكود لديك فهو يقوم بافراغ الخلابا الموجود بها المعادلات . Sheets("Input").Range("A6:A36,D6:F36,O6:S36,AA6:AE36").Select Selection.ClearContents وهدا مثال لتجربة العمل على الملف https://streamable.com/xnrgeb بالتوفيق............ Payroll123-3-2020 - Copy(4).xlsm

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

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

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

اخي المعادلة تشتغل بدون ادنى مشكلة تفضل شوف 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) او رقم اللجنة المجاورة لاسم التلميد وبالنسبة لشيت استمارة غياب ماهي طريقة استدعاء التلميد الغائب مثلا ادخال الاسم في خلية معينة او رقم الصف او...............

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