اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

مقارنه بين برنامجين اكسل

reem2009a

بواسطه reem2009a
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by reem2009a,

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

reem2009a

reem2009a

قام بنشر
قام بنشر (معدل)

مرحبا جميعا 

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

اريد المقارنه بين الاسماء الجديده المضافه  او الاسماء المحذوفه ومقارنه بين الرواتب اذا زادت اونقصت بين الشهرين لكل منتسب  

وهاي البرنامجين مرفقه لشهر تشرين وايلول 

‎⁨ايلول⁩.xlsx ‎⁨تشرين الاول⁩.xlsx

تم تعديل بواسطه reem2009a
تعديل للمطلوب
رابط هذا التعليق
شارك
عبدالله بشير عبدالله

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

قام بنشر
قام بنشر

السلام عليكم 

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

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

 

  • Like 2
رابط هذا التعليق
شارك
reem2009a

reem2009a

قام بنشر
  • الكاتب
قام بنشر (معدل)

مرحبا تظهر رساله

(تحقق من كتابه الاسم وهي الاسماء نفسها الي رسلتها)

وبالنسبه للاسماء اجمع اسماء الشهرين في حقل الاسم في الاكسل الجديد (المقارنه)

لان يوجد حقلين للرواتب وحقل للاسم 

علما وضعت الاكسل الثلاثه على سطح المكتب

تم تعديل بواسطه reem2009a
رابط هذا التعليق
شارك
عبدالله بشير عبدالله

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

قام بنشر
قام بنشر

 

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

قمت بتغير الاسم بالاكسل بهذي الطريقه. —-ايلول— و—-تشرين —-

 

 

اذا  تغير اسم الملف فلن تكون هناك نتائج

الملف يعمل بامتياز

1967090299_.png.53990c5b42998919fe089cc771b9017e.png

تم تعديل  ملف ايلول ياسم A وتشرين B

حمل الملفات الثلاتة التالية وضعها على سطح المكتب وافتح ملف نتائج المقارنة واضغط على الزر 

A.xlsx

B.xlsx

نتائج المقارنة.xlsb

 

 

  • Thanks 1
رابط هذا التعليق
شارك
reem2009a

reem2009a

قام بنشر
  • الكاتب
قام بنشر
في 28‏/10‏/2024 at 16:09, عبدالله بشير عبدالله said: 
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

 

رابط هذا التعليق
شارك
reem2009a

reem2009a

قام بنشر
  • الكاتب
قام بنشر

مرحبا  النتائج  صحيحه في اكسيل المقارنه للشهرين

ولكن عند وضعهم في الحاسبه نفس الرساله تظهر 

Subscipt out of rang 

يعني  في الشهر القادم ماهو الخطا الموجود عندي لجعل  الكود يعمل عندي 

علما من الاعدادات مفعله اعدادات الماكرو 

الافيس عندي 2010

انا وضعت الملفات الثلاثه على سطح المكتب

رابط هذا التعليق
شارك
reem2009a

reem2009a

قام بنشر
  • الكاتب
قام بنشر (معدل)

انا وضعت الملفات الثلاثه على سطح المكتب

والاسماء Aو B 

برنامج المقارنه المرسل مضبوط 

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

الخلل يمي 

البرنامج AوB على سطح المكتب وغير مفتوحات 

افتح اكسل المقارنه واضغط على امر المقارنه 

وتظهر رساله out of range 

تم تعديل بواسطه reem2009a
رابط هذا التعليق
شارك
محمد هشام.

محمد هشام.

قام بنشر
قام بنشر (معدل)

بعد إدن الأستاد @عبدالله بشير عبدالله  تعديل بسيط على الكود الخاص به

أخي @reem2009a جرب  بهذه الطريقة لا تحتاج لتحديد مسار سطح المكتب. عند تنفيذ الكود سيفتح لك مربع حوار لإختار ملف رقم1 وملف رقم2  مما سيغنيك عن  تحديد أسماء المصنفات داخل الكود ربما يناسبك  

filePath1 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select First File")
    If filePath1 = "False" Then Exit Sub

    filePath2 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select Second File")
    If filePath2 = "False" Then Exit Sub

    On Error GoTo ErrorHandler

    Set wb1 = Workbooks.Open(filePath1)
    Set wb2 = Workbooks.Open(filePath2)

    Set resultWs = ThisWorkbook.Sheets("Sheet1")
    resultWs.Cells.ClearContents
    resultWs.Range("A1:D1").Value = Array("اسم الموظف", "الحالة", _
    Left(wb1.Name, InStrRev(wb1.Name, ".") - 1), Left(wb2.Name, InStrRev(wb2.Name, ".") - 1))


'Code...........

End Sub

 

 

 

 

نتائج المقارنة.xlsb

تم تعديل بواسطه محمد هشام.
رابط هذا التعليق
شارك
reem2009a

reem2009a

قام بنشر
  • الكاتب
قام بنشر (معدل)

ممكن اضافه حقلين حقل للدرجه وحقل للمرحله لكل موظف؟  

الان ظهرت عندي الحقول والنتائج مطابقه 

فقط بحاجه الى اضافه العمودين للدرجه والمرحله

بالكسل A و الاكسل B

لتظهر مع نتائج المقارنه الدرجه والمرحله 

تم تعديل بواسطه reem2009a
رابط هذا التعليق
شارك
عبدالله بشير عبدالله

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

قام بنشر
قام بنشر (معدل)

السلام عليكم 

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

 بالرغم من ان ملف استاذنا يغنى عن الاظافة ويمكنك استخدامه

الا ان طلبك الجديد  اظافة عمودبن هو ما جعلنى اقوم بالرد

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

عند الضغط على الزر قم باختيار الملف الاول  ثم باخنيار الملف الثانى 

4 ساعات مضت, reem2009a said:

فقط بحاجه الى اضافه العمودين للدرجه والمرحله

ارجو التوضيح اكثر وهل العمودين للملفين او ملف واحد وبقضل ارفاق ملف للتوضبح وااترتيب المطلوب

نتائج المقارنة.xlsb

تم تعديل بواسطه عبدالله بشير عبدالله
  • Like 1
رابط هذا التعليق
شارك
reem2009a

reem2009a

قام بنشر
  • الكاتب
قام بنشر

لاكسل ايلول  بعد الاسم نضيف عمودين عمود للمرحله الوظيفيه  وعمود للمرحله 

واكسل تشرين الثاني. عمودين ايضا للدرجه والمرحله 

وبالمقارنه عندما يظهر  مع الاسم درجه ومرحله الموظف 

رابط هذا التعليق
شارك
عبدالله بشير عبدالله

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

قام بنشر
قام بنشر (معدل)

 بالرغم من انك لم توضحى ملف المقارنة الاخير  كبف ترتيب بياناته    هل تظهر درجته السابقة والحالية ومرحلته السابقة والحالية

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

يالنسبة للملفين  ايلول ونشرين ترتيب البيانات حسب الصورة 

1069287515_.png.8ab3cced299cf59799871f7a2c75b8a7.png

 

نتائج المقارنة.xlsb

 

تم تعديل بواسطه عبدالله بشير عبدالله
  • Thanks 1
رابط هذا التعليق
شارك
  • أفضل إجابة
reem2009a

reem2009a

قام بنشر
  • الكاتب
  • أفضل إجابة
قام بنشر (معدل)

شكرا جزيلا  @عبدالله بشير عبدالله 

شكرا جزيلا @محمد هشام.

هذا كان المطلوب 

اعجز عن شكركم

فقط سوال واحد 

انظر الى قيد زينب شاكر لماذا ياتي رقم الراتب  ولاتاتي المرحله والدرجه لاحظ بحقل الدرجه يوجد رقم الراتب وليس رقم المرحله 

🙏

تم تعديل بواسطه reem2009a
رابط هذا التعليق
شارك
reem2009a

reem2009a

قام بنشر
  • الكاتب
قام بنشر (معدل)

ساقوم بالتعديل يدوي على الدرجة والمرحله 

وشكرا حزيلا 

لان هذه حلت تعب ووقت وجهد كبير 

شكرا جزيلا

@عبدالله بشير عبدالله& @محمد هشام.

  

تم تعديل بواسطه reem2009a
رابط هذا التعليق
شارك
عبدالله بشير عبدالله

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

قام بنشر
قام بنشر (معدل)

جربى الملف المرفق  وفيه حالة نفس المرتب

المعايير التى بنى عليها الكود هي :-

 

  • المقارنة بين المرتبات:

  • يقوم الكود بمقارنة المرتب الرسمي لكل موظف بين الملفين، ويضيف النتيجة إلى العمود H في ملف المقارنة:

    • زيادة في المرتب: إذا كان المرتب في الملف الثاني أكبر من المرتب في الملف الأول.

    • نقص في المرتب: إذا كان المرتب في الملف الثاني أقل من المرتب في الملف الأول.

    • نفس المرتب: إذا كان المرتب في الملفين متساويًا.

    • محذوف: إذا كان اسم الموظف موجود في الملف الأول ولكن غير موجود في الملف الثاني.

    • جديد: إذا كان اسم الموظف موجود في الملف الثاني ولكن غير موجود في الملف الأول.

نتائج المقارنة.xlsb

 

تم تعديل بواسطه عبدالله بشير عبدالله
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع
×
×
  • اضف...

Important Information

  I accept