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

يعني تريد توثيق للتعديلات والحذف والاضافة ..... ابحث في المنتدى تجد العديد من المواضيع مثل هذا للاستاذ @jjafferr

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

بعد 9 شهور هذه المشاركة قرب يصير عندها عيال يا صديقي هههههه . تفضل نرجو منك عدم إهمال مواضيعك ، حتى نعلم إن كنت وجدت الحل أم لا !! Scanner 2 PDF.zip

أخى عبد الله تمت التجربة وأصبح لدينا معادلة وكود وكلاهما أكثر من رائع بارك الله فيك أخى الفاضل وجزاكم الله خيرا

حياك الله أخي بارك الله فيك وزادك من فضله وعلمه

وعليكم السلام ورحمة الله وبركاته .. 🙂 استخدم الدالة Trim لحذف المسافات قبل وبعد النص في حدث بعد التحديث للحقل .

وعليكم السلام مقاييس الصفحة الموجودة في التقرير يتم اخذها من الطابعة الافتراضية ، الى ان يقوم المستخدم باختيار طابعة اخرى ، لذا ، اذا الطابعة التي يقوم باختيارها المستخدم لا تحتوي على A3 ، فلن تجد هذا الاختيار من القائمة. يمكنك استخدام طابعة pdf افتراضية ، واجعل حجم الصفحة فيها الذي تريده ، سواء A3 او اكبر ، وستجد هذا الحجم موجود عند اختيارك لطابعة الـ pdf . انا استعمل هذه الطابعة المجانية :

وعليكم السلام ورحمة الله تعالى وبركاته بعد إذن السادة الأفاضل، يسعدني أن أشارك معكم هذه التجربة في محاولة مني للمساهمة والتفاعل الإيجابي والاستفاده من حضرتكم. Sub CalculateH23() Dim ws As Worksheet Dim countNonEmpty As Long Dim result As Variant Set ws = ThisWorkbook.Sheets("Sheet1") ' احسب عدد الخلايا غير الفارغة في النطاق B11:I15 countNonEmpty = Application.WorksheetFunction.CountA(ws.Range("B11:I15")) ' تحقق من الشرط في الخلية F23 If ws.Range("F23").Value = "الأول" Or ws.Range("F23").Value = "الثاني" Then result = Application.WorksheetFunction.Min(25, countNonEmpty) ElseIf ws.Range("F23").Value = "الثالث" Then result = countNonEmpty Else result = "" End If ' وضع النتيجة في الخلية H23 ws.Range("H23").Value = result End Sub

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

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

الكمبوبوكس كذلك ياخذ بياناته من الجدول او الاستعلام ، فالبيانات متغيره ، حالها حال الاستعلام. والجواب نفسه: بمعنى: اعمل جدول اسمه tbl_Movements ، حقوله : Auto_ID= ترقيم تلقائي Auto_Date= تاريخ ، وقيمته الافتراضية ()Now Employee_ID= رقم (رقم الموظف) Employee_Dept= نص (مكان العمل) Employee_Dept_Date= تاريخ (تاريخ نقل الموظف الى هذه الدائرة) ثم تعمل استعلام qry_Movements ، وفيها المعيار يكون عن طريق التاريخ. وفي النموذج عند نقل موظف من مكان الى آخر (حدث بعد التحديث) ، يجب "الحاق" القيمة الجديدة الى هذا الجدول ، وقيمة تاريخ النقل ، وتعمل مقارنة بين مكان عمل الموظف من هذا الاستعلام ، مع مكان العمل في الجدول الاصل ، ومنه تقدر تعرف من اللي تم تغيير مكانه.

وعليكم السلام ورحمة الله وبركاته احاول افهم قصدك: 1. عندك استعلام بمعايير معينة ، 2. احد حقول الاستعلام تم تغيير قيمته ، وهو نقل موظف الى مكان آخر ، تريد تعرف هذا الموظف؟ اذا كان هذا سؤالك ، فالجواب: لا يمكن ، فالاستعلام يعطيك صورة من بيانات الجدول. نعم يمكن ، اذا عملت جدول خاص بتخزين قيم هذا الحقل بشكل سجل/سجلات ، ويمكن مقارنة هذه السجلات بقيم الجدول الحالي لهذا الحقل. 3. لم افهم ما دور الكومبوبوكس والتقرير.

اخي فادي 🙂 شكرا جزيلا لك على المواصلة للنهاية لإرضاء الزبون 🙂 اخي الدكتور الحلبي 🙂 كلنا في خدمتكم 🙂

إدن لنفترض أننا سنقوم باستخراج البيانات من الأعمدة H:M كما هو ظاهر لديك على الصورة إلى ورقة 2 مثلا Sub CreateShift() Dim lastRow As Long, i As Long, j As Long, kay As String, c As String Dim tbl As Variant, Names As Collection, cell As Range, name As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row tbl = WS.Range("H4:M" & lastRow).Value For i = 1 To lastRow - 3 dest.Cells(1, i + 1).Value = tbl(i, 2) dest.Cells(2, i + 1).Value = tbl(i, 1) If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then Colors dest.Cells(1, i + 1), RGB(200, 200, 255) Colors dest.Cells(2, i + 1), RGB(255, 153, 0) End If Next i Set Names = New Collection On Error Resume Next For i = 1 To UBound(tbl, 1) For j = 3 To 6 If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j)) Next j Next i On Error GoTo 0 For i = 1 To Names.Count dest.Cells(i + 2, 1).Value = Names(i) Next i With dest.Range("A1:A2") .ClearFormats: .Merge: .Value = "الإســـم": .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter: .Font.Bold = True .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255) .Interior.color = RGB(200, 200, 255) End With For i = 1 To lastRow - 3 For j = 1 To Names.Count If Not IsEmpty(dest.Cells(j + 2, 1)) Then name = Names(j) c = dest.Cells(1, i + 1).Value kay = "" For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row) If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then kay = (cell.Column - 9) & " مخزن" Exit For End If Next cell dest.Cells(j + 2, i + 1).Value = kay With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1)) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).color = RGB(0, 0, 255) End With End If Next j Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Colors(cell As Range, color As Long) With cell .Interior.color = color .Font.Bold = True .Borders(xlEdgeBottom).LineStyle = xlContinuous End With End Sub New.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

نعم صحيح ، ما تفضل به معلمي الفاضل الأستاذ جعفر حل ابسط واسهل ولم اتطرق له للحفاظ على تصميمك في المرفق . اما بالنسبة لتعديل تصميم النموذج الفرعي في وضع النموذج الجدولي ، تابع هذا المرفق من موضوع سابق 20231119_184539.zip

وعليكم السلام ورحمة الله تعالى وبركاته في الخلية A4 ضع احدى المعادلات التالية مع سحبها يسارا لغاية عمود L وسحبها أسفل لغاية الصف الدي يناسبك =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, SMALL(IF('بيانات الطلاب'!$B$3:$B$100=$B$1, ROW('بيانات الطلاب'!$B$3:$B$100)-ROW('بيانات الطلاب'!B$3)+1), ROW(1:1))), "") أو =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, AGGREGATE(15, 6, ROW('بيانات الطلاب'!$B$3:$B$100) -ROW('بيانات الطلاب'!B$3)+1/( 'بيانات الطلاب'!$B$3:$B$100=$B$1), ROW(1:1))), "") أو =FILTER('بيانات الطلاب'!A$3:A$100, 'بيانات الطلاب'!$B$3:$B$100 = $B$1) متابعة الطلاب.xlsx باستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Long, j As Long, clé As String, IRow As Long, col As Long Dim WS As Worksheet: Set WS = Worksheets("بيانات الطلاب") Dim F As Worksheet: Set F = Worksheets("متابعة الطلاب") If Not Intersect(Target, Me.Range("B1")) Is Nothing Then d = 4 clé = F.Range("B1").Value IRow = WS.Range("B3:B" & WS.Rows.Count).Find("*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Application.ScreenUpdating = False F.Range("A4:L" & F.Rows.Count).ClearContents For j = 3 To IRow If WS.Cells(j, 2).Value = clé Then For col = 1 To 12 F.Cells(d, col).Value = WS.Cells(j, col).Value Next col d = d + 1 End If Next j Application.ScreenUpdating = True End If End Sub متابعة الطلاب.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الإسم =IFERROR(INDEX(A!B$3:B$1000, SMALL(IF(A!$A$3:$A$1000=$E$4, ROW(A!$A$3:$A$1000)-ROW(A!$A$3)+1), ROW()-5)), "") التشخيصي =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0)), "") التقويم =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0) + 1), "") A.xlsx

وما زلت تقع في نفس الخطأ !!!!!!! أرفق ملف اذا سمحت

هل تقصد ان جدول البيانات 2/ النوع و الجهة موجودة مسبقا على الجدول فقط يتم تجميع الأرقام و الشرط: عدم تكرار نفس النوع والجهة معاً ادا كان هدا ما تقصده يكفي وضع المعادلة التالية في عمود H =IF(AND(G4<>"", F4<>""), IFERROR(SUMIFS(D4:D100, C4:C100, G4, B4:B100, F4), ""), "") أما إدا كنت ترغب باستخراج البيانات بالشكل الواضح في الصورة بدون وضع بيانات مسبقا استخدم الكود التالي في حدث ورقة 1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Set rng = Intersect(Target, Me.Range("B4:D" & Me.Rows.Count)) If Not rng Is Nothing Then TotalNonTri End If End Sub Sub TotalNonTri() Dim a() As Variant, i&, lig&, key As Variant, tmp As Variant Dim WS As Worksheet, d As Object, tbl As Variant, n As String Set d = CreateObject("Scripting.Dictionary") Set WS = Sheets("Sheet1") tbl = Range("B4:D" & Cells(Rows.Count, "B").End(xlUp).Row).Value Application.ScreenUpdating = False WS.Range("F4:H" & WS.Rows.Count).ClearContents For i = LBound(tbl, 1) To UBound(tbl, 1) If Not IsEmpty(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then n = tbl(i, 1) & "|" & tbl(i, 2) If d.Exists(n) Then d(n) = d(n) + tbl(i, 3) Else d(n) = tbl(i, 3) End If End If Next i ReDim a(1 To d.Count, 1 To 3) lig = 1 For Each key In d.Keys tmp = Split(key, "|") a(lig, 1) = tmp(0): a(lig, 2) = tmp(1): a(lig, 3) = d(key) lig = lig + 1 Next key With Range("F4").Resize(d.Count, UBound(a, 2)) .Value = a End With Application.ScreenUpdating = True End Sub Book1.xlsb

ضع الأكواد التالية في حدث ورقة natiga Private Sub Worksheet_Activate() UpdateData End Sub '============ Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("A10:A25")) Is Nothing Then UpdateData End If End Sub '=========== Private Sub UpdateData() Dim ColmA As Variant, msg As String, i As Long, tmp As Variant, col As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Feuil1") Dim item As Range: Set item = WS.Range("K2:K9") Dim data As Range: Set data = WS.Range("L2:O9") For i = 10 To 25 ColmA = Me.Range("A" & i).Value Me.Range("B" & i).ClearContents If Trim(ColmA) = "" Then GoTo lig On Error Resume Next tmp = Application.Match(ColmA, item, 0) On Error GoTo 0 If Not IsError(tmp) Then msg = "بدون نتيجة" For col = data.Columns.Count To 1 Step -1 If Trim(data.Cells(tmp, col).Value) <> "" Then msg = data.Cells(tmp, col).Value Exit For End If Next col Me.Range("B" & i).Value = msg Else Me.Range("A" & i).Resize(1, 2).ClearContents MsgBox "الكود " & ColmA & " غير موجود", vbExclamation End If lig: Next i End Sub المعادلة =IF(A10="","",IFERROR(LOOKUP(2,1/(INDEX(Feuil1!$L$2:$O$9, MATCH(A10,Feuil1!$K$2:$K$9,0),0)<>""),INDEX(Feuil1!$L$2:$O$9,MATCH(A10,Feuil1!$K$2:$K$9,0),0)),"بدون نتيجة")) ppp7.xlsb

وعليكم السلام ورحمة الله وبركاته تم عمل كود بزر 1-1.xlsb ملفك وبه المغادلة 1-1.xlsx

من خلال استعلام جديد ، اختر الجدول ، وبالافتراض ان الحقل اسمه "رصيد" اضف التعبيرات الثلاثة التالية في الحقول :- دائن: IIf([رصيد] < 0, [رصيد], Null) مدين: IIf([رصيد] > 0, [رصيد], Null) منتهى: IIf([رصيد] = 0, [رصيد], Null) جرب واخبرني بالنتيجة