كود لمعرفة الفرق: درجات المواد قبل و بعد المراجعة والرفع

بلانك · الأربعاء at 11:54

الكود لمعرفة الفرق _ مطلو ب بالملف

**Foksh** · الأربعاء at 13:29

وعليكم السلام ورحمة الله وبركاته ,,

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

في مديول جديد يتم اضافة الكود التالي :-

Public Sub HighlightGradeDifferencesGeneral(ByVal sheetObject As Worksheet, _
                                          ByVal rangeBeforeAddress As String, _
                                          ByVal rangeAfterAddress As String, _
                                          Optional ByVal showMessage As Boolean = True)

    Dim rangeBefore As Range
    Dim rangeAfter As Range
    Dim cellAfter As Range
    Dim cellBefore As Range
    Dim i As Long
    Dim j As Long
    Dim highlightColor As Long

    On Error GoTo ErrorHandler

    Set rangeBefore = sheetObject.Range(rangeBeforeAddress)
    Set rangeAfter = sheetObject.Range(rangeAfterAddress)

    highlightColor = 6

    If rangeBefore.Rows.Count <> rangeAfter.Rows.Count Or _
       rangeBefore.Columns.Count <> rangeAfter.Columns.Count Then
        If showMessage Then
            MsgBox "نطاق 'قبل' (" & rangeBeforeAddress & ") ونطاق 'بعد' (" & rangeAfterAddress & ") " & _
                   "في الورقة '" & sheetObject.Name & "' ليسا بنفس الأبعاد . يرجى التحقق", vbExclamation + vbMsgBoxRight, ""
        End If
        Exit Sub
    End If

    Application.EnableEvents = False

    rangeBefore.Interior.ColorIndex = xlNone
    rangeAfter.Interior.ColorIndex = xlNone

    For i = 1 To rangeAfter.Rows.Count
        For j = 1 To rangeAfter.Columns.Count
            Set cellAfter = rangeAfter.Cells(i, j)
            Set cellBefore = rangeBefore.Cells(i, j)

            If Not IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value) Then
                If cellAfter.Value <> cellBefore.Value Then
                    cellAfter.Interior.ColorIndex = highlightColor
                    cellBefore.Interior.ColorIndex = highlightColor
                End If
            ElseIf (IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value)) Or _
                   (NotEmpty(cellAfter.Value) And IsEmpty(cellBefore.Value)) Then
                cellAfter.Interior.ColorIndex = highlightColor
                cellBefore.Interior.ColorIndex = highlightColor
            End If
        Next j
    Next i

    If showMessage Then
        MsgBox "اكتملت المقارنة وتم تلوين الاختلافات في الورقة '" & sheetObject.Name & "'.", vbInformation + vbMsgBoxRight, ""
    End If

ErrorHandler:
    Application.EnableEvents = True
    If Err.Number <> 0 And showMessage Then
        MsgBox "حدث خطأ في الورقة '" & sheetObject.Name & "': " & Err.Description, vbCritical + vbMsgBoxRight, ""
    End If
End Sub

Function NotEmpty(cellValue As Variant) As Boolean
    NotEmpty = Not IsEmpty(cellValue)
End Function

وفي حدث Worksheet_Change للورقة التي تريدها ، نستخدم الاستدعاء بالشكل التالي :-

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim watchRangeBefore_Sheet1 As Range
    Dim watchRangeAfter_Sheet1 As Range
    Dim ws As Worksheet

    Set ws = Me

    ' --- حدد النطاقات الخاصة بـ Sheet1 ---
    Dim beforeAddress_Sheet1 As String
    Dim afterAddress_Sheet1 As String

    beforeAddress_Sheet1 = "B3:I14"  ' نطاق "قبل" في Sheet1
    afterAddress_Sheet1 = "K3:R14" ' نطاق "بعد" في Sheet1

    On Error GoTo SafeExit

    Set watchRangeBefore_Sheet1 = ws.Range(beforeAddress_Sheet1)
    Set watchRangeAfter_Sheet1 = ws.Range(afterAddress_Sheet1)

    If Not Intersect(Target, watchRangeBefore_Sheet1) Is Nothing Or _
       Not Intersect(Target, watchRangeAfter_Sheet1) Is Nothing Then

        Call HighlightGradeDifferencesGeneral(sheetObject:=ws, _
                                              rangeBeforeAddress:=beforeAddress_Sheet1, _
                                              rangeAfterAddress:=afterAddress_Sheet1, _
                                              showMessage:=False)
    End If

SafeExit:
    If Err.Number <> 0 Then
    End If
End Sub

لاحظ أنه في كود الاستدعاء داخل الورقة التي تريد التطبيق عليها ، تستطيع تحديد النطاق من - إلى كيفما تشاء ، وطبعاً مع ضرورة تغيير اسم الورقة بدلاً من Sheet1 إلى اسم الورقة الثانية في حال اري الاستدعاء في أكثر من ورقة .

هذا سيضمن لك الإستدعاء مع التحديد النطاق ( قبل و بعد ) لكل ورقة ولكن بدالة واحدة مرنة .

الملف بعد التطبيق :-

درجات المواد.xlsm

بلانك · الأربعاء at 14:16

بارك الله فيك وجعله في ميزان حسناتك . وعيد اضحى كريم عليك

hegazee · الأربعاء at 15:41

كود رائع للاستاذ @Foksh إليك حل آخر بالتنسيق الشرطي

درجات المواد(2).xlsx

**Foksh** · الأربعاء at 16:13

نعم صحيح ، ما تم تنفيذه من طرفكم أستاذي الكريم ، جميل جداً :wub: .

وهو بالفعل ما ابتعدت عنه وبحثت عن مرونة تحكم بالنطاقات المختلفة وباقي التفاصيل .... إلخ .

**محمد هشام.** · الأربعاء at 16:21

وعليكم السلام ورحمة الله تعالى وبركاته

بطريقة أخرى

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

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, j As Long, Tbl1 As Range, Tbl2 As Range
    Dim a As Range, b As Range, tmp As Range
    
    Dim xColor As Long: xColor = RGB(255, 204, 0)
    Dim ColArr As Long: ColArr = 8
    Dim départ As Long: départ = 12
    Dim début As Long: début = 3

    On Error GoTo CleanExit

    Set Tbl1 = Range("B" & début).Resize(départ, ColArr)
    Set Tbl2 = Range("K" & début).Resize(départ, ColArr)

    If Intersect(Target, Union(Tbl1, Tbl2)) Is Nothing Then Exit Sub

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    For Each tmp In Intersect(Target, Union(Tbl1, Tbl2))
        i = tmp.Row - début + 1
        If i >= 1 And i <= départ Then
            For j = 1 To ColArr
                Set a = Tbl1.Cells(i, j)
                Set b = Tbl2.Cells(i, j)
                If a.Value <> b.Value Then
                    a.Interior.Color = xColor
                    b.Interior.Color = xColor
                Else
                    a.Interior.ColorIndex = xlNone
                    b.Interior.ColorIndex = xlNone
                End If
            Next j
        End If
    Next tmp

CleanExit:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

درجات المواد v3.xlsb

hegazee · الأربعاء at 16:50

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

درجات المواد v4.xlsb

**Foksh** · الأربعاء at 16:58

ما شاء الله ، تبارك الله :wub: ..

أفكار وحلول جميلة ، من الأساتذة ( @hegazee ، @محمد هشام. ... ) ، ولهذا وددت أيضاً تطوير الفكرة بحيث عند وجود أكثر من فارق بين ( قبل وبعد ) في نفس الصف ، ان يتم تمييز كل فارق بلون مختلف لتسهل معرفة وتتبع الفروقات عند السجلات الكبيرة . حيث تم تعديل الدالة الرئيسية فقط كالآتي :-

Public Sub HighlightGradeDifferencesGeneral(ByVal sheetObject As Worksheet, _
                                          ByVal rangeBeforeAddress As String, _
                                          ByVal rangeAfterAddress As String, _
                                          Optional ByVal showMessage As Boolean = True)

    Dim rangeBefore As Range
    Dim rangeAfter As Range
    Dim cellAfter As Range
    Dim cellBefore As Range
    Dim i As Long
    Dim j As Long
    Dim colorPalette As Variant
    Dim colorIndex As Long
    
    colorPalette = Array(6, 3, 4, 7, 8, 9, 10, 12)
    
    On Error GoTo ErrorHandler

    Set rangeBefore = sheetObject.Range(rangeBeforeAddress)
    Set rangeAfter = sheetObject.Range(rangeAfterAddress)

    If rangeBefore.Rows.Count <> rangeAfter.Rows.Count Or _
       rangeBefore.Columns.Count <> rangeAfter.Columns.Count Then
        If showMessage Then
            MsgBox "نطاق 'قبل' (" & rangeBeforeAddress & ") ونطاق 'بعد' (" & rangeAfterAddress & ") " & _
                   "في الورقة '" & sheetObject.Name & "' ليسا بنفس الأبعاد . يرجى التحقق", vbExclamation + vbMsgBoxRight, ""
        End If
        Exit Sub
    End If

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    rangeBefore.Interior.colorIndex = xlNone
    rangeAfter.Interior.colorIndex = xlNone

    For i = 1 To rangeAfter.Rows.Count
        colorIndex = 0
        
        For j = 1 To rangeAfter.Columns.Count
            Set cellAfter = rangeAfter.Cells(i, j)
            Set cellBefore = rangeBefore.Cells(i, j)

            If Not IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value) Then
                If cellAfter.Value <> cellBefore.Value Then
                    cellAfter.Interior.colorIndex = colorPalette(colorIndex)
                    cellBefore.Interior.colorIndex = colorPalette(colorIndex)
                    
                    colorIndex = (colorIndex + 1) Mod (UBound(colorPalette) + 1)
                End If
            ElseIf (IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value)) Or _
                   (Not IsEmpty(cellAfter.Value) And IsEmpty(cellBefore.Value)) Then
                cellAfter.Interior.colorIndex = colorPalette(colorIndex)
                cellBefore.Interior.colorIndex = colorPalette(colorIndex)
                
                colorIndex = (colorIndex + 1) Mod (UBound(colorPalette) + 1)
            End If
        Next j
    Next i

    If showMessage Then
        MsgBox "اكتملت المقارنة وتم تلوين الاختلافات في الورقة '" & sheetObject.Name & "'.", vbInformation + vbMsgBoxRight, ""
    End If

ErrorHandler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    If Err.Number <> 0 And showMessage Then
        MsgBox "حدث خطأ في الورقة '" & sheetObject.Name & "': " & Err.Description, vbCritical + vbMsgBoxRight, ""
    End If
End Sub

الملف بعد إضافة التعديل

درجات المواد.xlsm

وصورة توضيحية للنتيجة

image.png.70eaa5162a145bd3aeca0a8534141c01.png

**محمد هشام.** · الأربعاء at 19:33

2 ساعات مضت, Foksh said:

فارق بلون مختلف لتسهل معرفة وتتبع الفروقات عند السجلات الكبيرة

ما شاء الله جزاكم الله خيرا على هذا العمل الرائع والفكرة المميزة اخي @Foksh

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

بالتوفيق.........

1.PNG.efa93c582653b2e2659bd803f489da4f.PNG

نسخة معدلة من الكود لتحقيق هذا الهدف

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long, c As Long, Tbl1, Tbl2, a, b, tmp As Long, xCount As Long, key As String
    Dim xColor, cnt As Object, j As Long, i As Long, x As Long, ky As String
    Const départ = 3, ColArr = 18, début = 2, LastCol = 9, f = 9, Irow = 1

    If Target.CountLarge > 1 Then Exit Sub

    Set cnt = CreateObject("Scripting.Dictionary")
    xColor = Array( _
        RGB(255, 255, 0), RGB(255, 0, 0), RGB(0, 176, 80), RGB(0, 112, 192), RGB(255, 192, 0), RGB(112, 48, 160), _
        RGB(255, 0, 255), RGB(0, 176, 240), RGB(146, 208, 80), RGB(255, 102, 0), RGB(204, 0, 153), RGB(0, 255, 255), _
        RGB(255, 153, 204), RGB(153, 51, 0), RGB(102, 102, 255), RGB(255, 204, 153), RGB(51, 153, 102), RGB(153, 0, 0), _
        RGB(0, 102, 204), RGB(204, 153, 255), RGB(255, 255, 153), RGB(204, 0, 0), RGB(0, 153, 0), RGB(0, 51, 102), _
        RGB(255, 128, 0), RGB(102, 0, 102), RGB(0, 204, 204), RGB(255, 102, 102), RGB(102, 255, 102), RGB(102, 102, 153))

    On Error GoTo CleanUp

    With Me
        If Intersect(Target, .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f))) Is Nothing Then Exit Sub
        SetApp False

     .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f)).Interior.colorIndex = xlNone
       With .Range("T:W"): .UnMerge: .ClearContents: End With
        Me.[T1:W1].Value = Array("الإسم", "المادة", "قبل", "بعد")

        tmp = 2: j = 0: xCount = 0
        For r = départ To départ + ColArr - 1
            b = .Cells(r, Irow).Value
            For c = début To LastCol
                Tbl1 = .Cells(r, c).Value: Tbl2 = .Cells(r, c + f).Value: a = .Cells(2, c).Value
                    If IsEmpty(Tbl1) Then Tbl1 = ""
                    If IsEmpty(Tbl2) Then Tbl2 = ""
                    If CStr(Tbl1) <> CStr(Tbl2) Then
                    xCount = xCount + 1
                    key = b & "|" & a & "|" & Tbl1 & "|" & Tbl2
                    If Not cnt.Exists(key) Then
                        cnt.Add key, xColor(j Mod (UBound(xColor) + 1))
                        j = j + 1
                    End If
                    .Cells(r, c).Interior.Color = cnt(key)
                    .Cells(r, c + f).Interior.Color = cnt(key)
                    .Cells(tmp, "T").Resize(1, 4).Value = Array(b, a, Tbl1, Tbl2)
                    tmp = tmp + 1
                End If
            Next c
        Next r

        If xCount > 0 Then
            .Cells(tmp, "T").Value = "إجمالي الاختلافات"
            .Cells(tmp, "U").Value = xCount

            x = 2: ky = .Cells(x, "T").Value
            For i = 3 To tmp
                If .Cells(i, "T").Value <> ky Or .Cells(i, "T").Value = "" Then
                    If i - 1 > x Then .Range("T" & x & ":T" & i - 1).Merge
                    x = i
                    ky = .Cells(i, "T").Value
                End If
            Next i
        Else
            With .Range("T:W"): .UnMerge: .ClearContents: End With
        End If

CleanUp:
        SetApp True
        Set cnt = Nothing

    End With
End Sub

Private Sub SetApp(ByVal enable As Boolean)
    With Application
        .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable
        .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

درجات المواد v4.xlsb

تم تعديل الأربعاء at 19:50 بواسطه محمد هشام.

**Foksh** · الأربعاء at 20:24

44 دقائق مضت, محمد هشام. said:

ما شاء الله جزاكم الله خيرا

وإياكم أخي @محمد هشام. ، وأحسنتم التطوير ..

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

وأنتم قد أحسنتم السير بهذا الطريق 👍🏻

جزاكم الله كل الخير على ترجمتكم الجميلة لفكرتي البسيطة :clapping:

تسجيل الدخول

كود لمعرفة الفرق: درجات المواد قبل و بعد المراجعة والرفع

الردود الموصى بها

بلانك

Foksh

بلانك

hegazee

Foksh

محمد هشام.

hegazee

Foksh

محمد هشام.

Foksh

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information