عبدالله بشير عبدالله

السلام عليكم ورحمة الله وبركاته الملف به 1048576 مليون معادلة صفيف في صفحة الموظفين به 1048576 مليون معادلة صفيف في صفحة المعلمبن 8 تم حذف المعادلات ويمكنك اعادة كتابنها حسب حاجنك لم توضح ما هو الذي تريد البحث عنه وفي اي شبتات واين توضع نتيجة البحث على كل حال محاولة حسب تخمينى يوجد زر في شيت الرئيسية باسم بحث مدرسة ديوان الطالب مفصلة 26-10-2024.xlsb

لو طبقت ماطلبناه منك وهو كنابة النتائج يدويا لسهلت علينا الامر ,, اذاكان رامي يفترض ترقيمه 16 كما ذكرت معنى هذا هو اول خطأ في الترقيم وكل ماسبقه صحيح واخرهم ابو رامي وترقيمه 15 ولكن حسب من تنطبق عليه الشروط حسب فهمي يكون رامي ترقيمه 12 وليس 16 جرب المعادلة =IF(J2 > 110; IF(I2 <> ""; MAX(H$1:H1) + 1; MAX(H$1:H1)); "")

السلام عليكم ورحمة الله وبركاته جرب المعادلة =IF(AND(B2=0; A2>0); A2 + 1; IF(AND(B2>=1; A2=0); 0; IF(AND(B2>=1; A2>0); A2 - B2; A2))) الملف المصنف1.xlsx

اخونا الفاضل : السلام عليكم ورحمة الله وبركاته النتائج اليدوية : - المقصود بها ان تكتب في العمود G مثلا الترقيم الصحيح الذي تريده يدويا في الخلايا الملونة حتى بتضح لنا اين الخلل في الترقيم مع ترك العمود H كما هو ثانبا العمود i لاحظت انك تذكر اكبر من الصفر هل العمود تصي ام رقمي ننتظر توضبحكم مع وافر التقدير والاحترام

وعليكم السلام ورحمة الله وبركانه في الإصدارات الحالية من Excel، حسب علمى لا يوجد والله اعلم

وعليكم السلام ورحمة الله وبركاته لو ارفقت لنا ملفك لاختصرت الوقت او ارفقت الجملة التى بها خطأ لسهلت لنا الامر يدون ملف محاولات قد تصيب وقد تخطئ ريما السبب من جملة FILESEARCH والتي اعتقد انها غير متوافقة مع الاصدارات بعد 2003 ( غير متاكد منها) سنفترض ان الامر منها فيكون تعديل الكود كالتالى Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox) Dim val As String Dim Namey As String Dim fso As Object Dim folder As Object Dim file As Object combo2.Clear If combo1.Value = "" Then MsgBox "الرجاء اختيار شيت من القائمة", vbExclamation Exit Sub End If val = ThisWorkbook.Path & "\" & combo1.Value & "\Ser" Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(val) Then Set folder = fso.GetFolder(val) For Each file In folder.Files If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then Namey = file.Name Namey = Left(Namey, Len(Namey) - 5) ' إزالة الامتداد .xlsx combo2.AddItem Namey End If Next file Else MsgBox "المجلد غير موجود: " & val, vbExclamation End If Set fso = Nothing Set folder = Nothing Set file = Nothing End Sub او جرب الكود التالى Private Sub FrstChnge(combo1 As ComboBox, combo2 As ComboBox) Dim val As String Dim filePath As String Dim fileName As String val = combo1.Value combo2.Clear If val = "" Then Exit Sub filePath = ThisWorkbook.Path & "\" & val & "\Ser\" fileName = Dir(filePath & "*.xls*") Do While fileName <> "" combo2.AddItem Left(fileName, Len(fileName) - 4) fileName = Dir Loop End Sub اذا لم بعمل ارفق ملفك وفقك الله

وعليكم السلام ورحمة الله وبركاته =CEILING(G14*E14; 1) بالتوفيق

وعليكم السلام ورحمة الله وبركاته تم عمل كود بدل معادلات الصفيف والترتيب الكود ينظر الى السنة اولا بمبن العلامة المائلة ثم يبحث عن اصغر رقم يسارا تم عمل قائمة اختيار لاختيار N° Bordereau وكلما اضفت رقما اضيف الى القائمة لك كل الاحترام والتقدير BORDEREAU FACILE1.xlsm

جربى الملف المرفق وفيه حالة نفس المرتب المعايير التى بنى عليها الكود هي :- المقارنة بين المرتبات: يقوم الكود بمقارنة المرتب الرسمي لكل موظف بين الملفين، ويضيف النتيجة إلى العمود H في ملف المقارنة: زيادة في المرتب: إذا كان المرتب في الملف الثاني أكبر من المرتب في الملف الأول. نقص في المرتب: إذا كان المرتب في الملف الثاني أقل من المرتب في الملف الأول. نفس المرتب: إذا كان المرتب في الملفين متساويًا. محذوف: إذا كان اسم الموظف موجود في الملف الأول ولكن غير موجود في الملف الثاني. جديد: إذا كان اسم الموظف موجود في الملف الثاني ولكن غير موجود في الملف الأول. نتائج المقارنة.xlsb وهذا الملف خاص بمن زادت او نقصت او حذفو او جددفقط بدون نفس المرتب نتائج المقارنة1.xlsb

ساقوم بالتعديل ان شاء الله

السلام عليكم ورحمة الله وبركانه صبحكم الله بالخير جرب الملف وان لم يكتمل حدد ما هو المطلوب لك وافر التقدير والاحترام نقل أعمدة محددة من ورقة الى أكثر من ورقة+222222.xlsm

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

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

كود ربما اسرع جربه نقل أعمدة محددة من ورقة الى أكثر من ورقة.xlsm

اللهم صَلِّ وسلم على نبينا محمد وعلى آله وصحبه أجمعين السلام عليكم ابو سجدة جرب الكود التالى ومعك ان شاء الله حتى تحقق طلبك الكود Sub نقل_الأعمدة() Dim wsMain As Worksheet Dim wsFirst As Worksheet Dim wsSecond As Worksheet Dim wsThird As Worksheet Dim lastRow As Long Dim colArr As Variant Set wsMain = Sheets("الرئيسية") Set wsFirst = Sheets("الورقة الأولى") Set wsSecond = Sheets("الورقة الثانية") Set wsThird = Sheets("الورقة الثالثة") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual colArr = Array(1, 4, 6, 28, 29) نقل_عمود_مع_التنسيقات wsMain, wsFirst, colArr colArr = Array(1, 2, 3, 4, 5, 6, 46) نقل_عمود_مع_التنسيقات wsMain, wsSecond, colArr colArr = Array(1, 4, 6, 17, 18, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45) نقل_عمود_مع_التنسيقات wsMain, wsThird, colArr Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub نقل_عمود_مع_التنسيقات(wsSource As Worksheet, wsTarget As Worksheet, cols As Variant) Dim lastRow As Long Dim i As Long Dim colNum As Integer lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row For i = LBound(cols) To UBound(cols) colNum = cols(i) wsTarget.Columns(colNum).ClearContents Next i For i = LBound(cols) To UBound(cols) colNum = cols(i) wsSource.Range(wsSource.Cells(1, colNum), wsSource.Cells(lastRow, colNum)).Copy wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteFormats Next i Application.CutCopyMode = False End Sub نقل أعمدة محددة من ورقة الى أكثر من ورقة.xlsm

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

اذا تغير اسم الملف فلن تكون هناك نتائج الملف يعمل بامتياز تم تعديل ملف ايلول ياسم A وتشرين B حمل الملفات الثلاتة التالية وضعها على سطح المكتب وافتح ملف نتائج المقارنة واضغط على الزر A.xlsx B.xlsx نتائج المقارنة.xlsb

جرب الكود التالى النتيجة فى G2 بمكن تعديلها فى الكود Sub CalculateResult() Dim cellCount As Long Dim result As Variant Dim dataRange As Range Dim cell As Range Set dataRange = Sheets("طباعة").Range("B7:I11") cellCount = 0 For Each cell In dataRange If cell.Value <> 0 And cell.Value <> "" Then cellCount = cellCount + 1 End If Next cell Select Case Sheets("طباعة").Range("F2").Value Case "الأول", "الثانى" If cellCount >= 25 Then result = 25 Else result = cellCount End If Case "الثالث" result = cellCount Case Else result = "" End Select Sheets("طباعة").Range("G2").Value = result MsgBox "تم حساب النتيجة: " & result الملف عدد الخلايا بشروط.xlsx

كذاك جرب المعادلة التالية فهل تتجاهل الفراغات والخلايا الصفرية =IF(OR(F23="الأول";F23="الثانى");IF(SUMPRODUCT(--(B11:I15<>0);--(B11:I15<>""))>=25;25;SUMPRODUCT(--(B11:I15<>0);--(B11:I15<>"")));IF(F23="الثالث";SUMPRODUCT(--(B11:I15<>0);--(B11:I15<>""));""))

نعم يمكن ذلك الملف به 3 اكواد عمل المعادلات بكود1.xlsb

السلام عليكم بعد اذن استاذنا الفاضل محمد هشام محاولة منى للمساهمة فى ملف اخينا ناصر المصرى اذا لم تحقق المطلوب ارفق الملف بالمعادلات =IF(OR(F23="الأول"; F23="الثانى"); IF(COUNTA(B11:I15) >= 25; 25; COUNTA(B11:I15)); IF(F23="الثالث"; COUNTA(B11:I15); "")) الملف عدد الخلايا بشروط.xlsx

السلام عليكم تم انشاء ملف جديد باسم نتائج المقارنة تم وضع كود به اضغط على الزر فقط بشرط الملفين تشرين وايلول يكونان مقفلين وان بكونا على سطح المكتب بمعنى الملفات الثلاتة على سطح المكتب وبنفس الاسماء الحالية يمكنك تعديل الاسماء من الكود ان اردت Sub CompareSalaries() Dim desktopPath As String Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet Dim resultWb As Workbook, resultWs As Worksheet Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long Dim empName As Variant Dim salary1 As Double, salary2 As Double Dim dictSalaries1 As Object, dictSalaries2 As Object desktopPath = Environ("UserProfile") & "\Desktop\" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(desktopPath & "__ايلول_.xlsx") Set wb2 = Workbooks.Open(desktopPath & "__تشرين الاول_.xlsx") Set resultWb = Workbooks("نتائج المقارنة.xlsB") Set ws1 = wb1.Sheets("ورقة1") Set ws2 = wb2.Sheets("ورقة1") Set resultWs = resultWb.Sheets("ورقة1") resultWs.Range("A2:D" & resultWs.Rows.Count).ClearContents resultWs.Range("A1:D1").Value = Array("الاسم", "الحالة", "راتب أيلول", "راتب تشرين الأول") Set dictSalaries1 = CreateObject("Scripting.Dictionary") Set dictSalaries2 = CreateObject("Scripting.Dictionary") lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow1 empName = ws1.Cells(i, 1).Value salary1 = ws1.Cells(i, 2).Value dictSalaries1(empName) = salary1 Next i lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow2 empName = ws2.Cells(i, 1).Value salary2 = ws2.Cells(i, 2).Value dictSalaries2(empName) = salary2 Next i j = 2 For Each empName In dictSalaries1.Keys If dictSalaries2.exists(empName) Then salary1 = dictSalaries1(empName) salary2 = dictSalaries2(empName) If salary1 <> salary2 Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "تغير في الراتب" resultWs.Cells(j, 3).Value = salary1 resultWs.Cells(j, 4).Value = salary2 j = j + 1 End If Else resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "محذوف" resultWs.Cells(j, 3).Value = dictSalaries1(empName) resultWs.Cells(j, 4).Value = "" j = j + 1 End If Next empName For Each empName In dictSalaries2.Keys If Not dictSalaries1.exists(empName) Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "جديد" resultWs.Cells(j, 3).Value = "" resultWs.Cells(j, 4).Value = dictSalaries2(empName) j = j + 1 End If Next empName wb1.Close False wb2.Close False resultWs.Columns("A:D").AutoFit With resultWs.Range("A1:D" & j - 1).Borders .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With MsgBox "تمت المقارنة وتم عرض النتائج في ورقة 'ورقة1' في مصنف 'نتائج المقارنة.xlsx'.", vbInformation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not wb1 Is Nothing Then wb1.Close False If Not wb2 Is Nothing Then wb2.Close False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub الملف نتائج المقارنة.xlsb

السلام عليكم الكود Sub ترحيل_الناجحين_والراسبين() Dim wsSource As Worksheet Dim wsPass As Worksheet Dim wsFail As Worksheet Dim lastRow As Long Dim i As Long Dim passRow As Long Dim failRow As Long Dim passCount As Long Dim failCount As Long Set wsSource = ThisWorkbook.Sheets("اجمالي4") Set wsPass = ThisWorkbook.Sheets("ناجح4") Set wsFail = ThisWorkbook.Sheets("دور ثاني") lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row passRow = 7 failRow = 7 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual wsPass.Rows("7:" & wsPass.Rows.Count).ClearContents wsFail.Rows("7:" & wsFail.Rows.Count).ClearContents For i = 5 To lastRow If InStr(1, LCase(wsSource.Cells(i, "BC").Value), "ناجح") > 0 Then wsPass.Cells(passRow, 2).Resize(1, 56).Value = wsSource.Cells(i, 2).Resize(1, 56).Value wsPass.Cells(passRow, 1).Value = passRow - 6 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat ' نسخ التنسيق passRow = passRow + 1 passCount = passCount + 1 ElseIf InStr(1, LCase(wsSource.Cells(i, "BC").Value), "راسب") > 0 Then wsFail.Cells(failRow, 2).Resize(1, 56).Value = wsSource.Cells(i, 2).Resize(1, 56).Value wsFail.Cells(failRow, 1).Value = failRow - 6 wsFail.Cells(failRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat ' نسخ التنسيق failRow = failRow + 1 failCount = failCount + 1 End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If passCount = 0 Then MsgBox "لا توجد سجلات ناجحة للترحيل." ElseIf failCount = 0 Then MsgBox "لا توجد سجلات راسبة للترحيل." Else MsgBox "تم ترحيل " & passCount & " ناجح(ة) و " & failCount & " راسب(ة) بنجاح." End If End Sub الملف عمل المعادلات بكود1.xlsb

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

السلام عليكم حل استاذنا محمد هشام وافى وكافى جزاه الله كل خير وطلبك كان معادلة ان اردتها بالكود غير الصف والمادة فى الخليتن فقط تم عمل قائمة للصفوف A (1).xlsb