reem2009a قام بنشر أكتوبر 28 مشاركة قام بنشر أكتوبر 28 (معدل) مرحبا جميعا عندي برنامجين رواتب لشهرين في الاكسل اريد المقارنه بين الاسماء الجديده المضافه او الاسماء المحذوفه ومقارنه بين الرواتب اذا زادت اونقصت بين الشهرين لكل منتسب وهاي البرنامجين مرفقه لشهر تشرين وايلول ايلول.xlsx تشرين الاول.xlsx تم تعديل أكتوبر 28 بواسطه reem2009a تعديل للمطلوب رابط هذا التعليق شارك More sharing options...
عبدالله بشير عبدالله قام بنشر أكتوبر 28 مشاركة قام بنشر أكتوبر 28 السلام عليكم تم انشاء ملف جديد باسم نتائج المقارنة تم وضع كود به اضغط على الزر فقط بشرط الملفين تشرين وايلول يكونان مقفلين وان بكونا على سطح المكتب بمعنى الملفات الثلاتة على سطح المكتب وبنفس الاسماء الحالية يمكنك تعديل الاسماء من الكود ان اردت 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 2 رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 29 الكاتب مشاركة قام بنشر أكتوبر 29 (معدل) مرحبا تظهر رساله (تحقق من كتابه الاسم وهي الاسماء نفسها الي رسلتها) وبالنسبه للاسماء اجمع اسماء الشهرين في حقل الاسم في الاكسل الجديد (المقارنه) لان يوجد حقلين للرواتب وحقل للاسم علما وضعت الاكسل الثلاثه على سطح المكتب تم تعديل أكتوبر 29 بواسطه reem2009a رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 29 الكاتب مشاركة قام بنشر أكتوبر 29 قمت بتغير الاسم بالاكسل بهذي الطريقه. —-ايلول— و—-تشرين —- ظهرت رساله حدث خطا: subscript out of range رابط هذا التعليق شارك More sharing options...
عبدالله بشير عبدالله قام بنشر أكتوبر 29 مشاركة قام بنشر أكتوبر 29 2 ساعات مضت, reem2009a said: قمت بتغير الاسم بالاكسل بهذي الطريقه. —-ايلول— و—-تشرين —- اذا تغير اسم الملف فلن تكون هناك نتائج الملف يعمل بامتياز تم تعديل ملف ايلول ياسم A وتشرين B حمل الملفات الثلاتة التالية وضعها على سطح المكتب وافتح ملف نتائج المقارنة واضغط على الزر A.xlsx B.xlsx نتائج المقارنة.xlsb 1 رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 30 الكاتب مشاركة قام بنشر أكتوبر 30 في 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 رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 30 الكاتب مشاركة قام بنشر أكتوبر 30 مرحبا النتائج صحيحه في اكسيل المقارنه للشهرين ولكن عند وضعهم في الحاسبه نفس الرساله تظهر Subscipt out of rang يعني في الشهر القادم ماهو الخطا الموجود عندي لجعل الكود يعمل عندي علما من الاعدادات مفعله اعدادات الماكرو الافيس عندي 2010 انا وضعت الملفات الثلاثه على سطح المكتب رابط هذا التعليق شارك More sharing options...
عبدللرحيم قام بنشر أكتوبر 30 مشاركة قام بنشر أكتوبر 30 راجع اسماء الملفات رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 30 الكاتب مشاركة قام بنشر أكتوبر 30 (معدل) انا وضعت الملفات الثلاثه على سطح المكتب والاسماء Aو B برنامج المقارنه المرسل مضبوط ولكن عند اعاده تجربته على حاسبتي لايعمل الخلل يمي البرنامج AوB على سطح المكتب وغير مفتوحات افتح اكسل المقارنه واضغط على امر المقارنه وتظهر رساله out of range تم تعديل أكتوبر 30 بواسطه reem2009a رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أكتوبر 30 مشاركة قام بنشر أكتوبر 30 (معدل) بعد إدن الأستاد @عبدالله بشير عبدالله تعديل بسيط على الكود الخاص به أخي @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 تم تعديل أكتوبر 30 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 30 الكاتب مشاركة قام بنشر أكتوبر 30 (معدل) ممكن اضافه حقلين حقل للدرجه وحقل للمرحله لكل موظف؟ الان ظهرت عندي الحقول والنتائج مطابقه فقط بحاجه الى اضافه العمودين للدرجه والمرحله بالكسل A و الاكسل B لتظهر مع نتائج المقارنه الدرجه والمرحله تم تعديل أكتوبر 30 بواسطه reem2009a رابط هذا التعليق شارك More sharing options...
عبدالله بشير عبدالله قام بنشر أكتوبر 30 مشاركة قام بنشر أكتوبر 30 (معدل) السلام عليكم فكرة الاستاذ محمد هشام افضل لانها تغنيك عن التعديل فى الكود فى الاشهر الاخرى فهى مرتة جدا وفى اي مكان وجود الملف وباى اسم فجزاه الله خيرا خير الجزاء بالرغم من ان ملف استاذنا يغنى عن الاظافة ويمكنك استخدامه الا ان طلبك الجديد اظافة عمودبن هو ما جعلنى اقوم بالرد تم تطبيق فكرة الاستاذ محمد هشام على الملف مع توضيح من زاد مرتبهم او نقص مرتبهم حسب طلبك عند الضغط على الزر قم باختيار الملف الاول ثم باخنيار الملف الثانى 4 ساعات مضت, reem2009a said: فقط بحاجه الى اضافه العمودين للدرجه والمرحله ارجو التوضيح اكثر وهل العمودين للملفين او ملف واحد وبقضل ارفاق ملف للتوضبح وااترتيب المطلوب نتائج المقارنة.xlsb تم تعديل أكتوبر 30 بواسطه عبدالله بشير عبدالله 1 رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 30 الكاتب مشاركة قام بنشر أكتوبر 30 لاكسل ايلول بعد الاسم نضيف عمودين عمود للمرحله الوظيفيه وعمود للمرحله واكسل تشرين الثاني. عمودين ايضا للدرجه والمرحله وبالمقارنه عندما يظهر مع الاسم درجه ومرحله الموظف رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 30 الكاتب مشاركة قام بنشر أكتوبر 30 عذروني لان تعبتكم ضفت حقلين الدرجه والمرحله للتوضيح اقصد كل موظف تظهر معه درجته والمرحله باكسل نتائج تظهر كل موظف درجته والمرحله ��تشرين الاول�.xlsx رابط هذا التعليق شارك More sharing options...
عبدالله بشير عبدالله قام بنشر أكتوبر 30 مشاركة قام بنشر أكتوبر 30 (معدل) بالرغم من انك لم توضحى ملف المقارنة الاخير كبف ترتيب بياناته هل تظهر درجته السابقة والحالية ومرحلته السابقة والحالية المهم جهزت ملف حسب تصورى للامر واذا كان هناك بعض الاعمدة فى ملف المقارنة ليست ضرورية فيمكنك اخفائها يالنسبة للملفين ايلول ونشرين ترتيب البيانات حسب الصورة نتائج المقارنة.xlsb تم تعديل أكتوبر 30 بواسطه عبدالله بشير عبدالله 1 رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 31 الكاتب مشاركة قام بنشر أكتوبر 31 (معدل) شكرا جزيلا @عبدالله بشير عبدالله شكرا جزيلا @محمد هشام. هذا كان المطلوب اعجز عن شكركم فقط سوال واحد انظر الى قيد زينب شاكر لماذا ياتي رقم الراتب ولاتاتي المرحله والدرجه لاحظ بحقل الدرجه يوجد رقم الراتب وليس رقم المرحله 🙏 تم تعديل أكتوبر 31 بواسطه reem2009a رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر أكتوبر 31 الكاتب مشاركة قام بنشر أكتوبر 31 (معدل) ساقوم بالتعديل يدوي على الدرجة والمرحله وشكرا حزيلا لان هذه حلت تعب ووقت وجهد كبير شكرا جزيلا @عبدالله بشير عبدالله& @محمد هشام. تم تعديل أكتوبر 31 بواسطه reem2009a رابط هذا التعليق شارك More sharing options...
عبدالله بشير عبدالله قام بنشر أكتوبر 31 مشاركة قام بنشر أكتوبر 31 ساقوم بالتعديل ان شاء الله رابط هذا التعليق شارك More sharing options...
أفضل إجابة عبدالله بشير عبدالله قام بنشر أكتوبر 31 أفضل إجابة مشاركة قام بنشر أكتوبر 31 (معدل) جربى الملف المرفق وفيه حالة نفس المرتب المعايير التى بنى عليها الكود هي :- المقارنة بين المرتبات: يقوم الكود بمقارنة المرتب الرسمي لكل موظف بين الملفين، ويضيف النتيجة إلى العمود H في ملف المقارنة: زيادة في المرتب: إذا كان المرتب في الملف الثاني أكبر من المرتب في الملف الأول. نقص في المرتب: إذا كان المرتب في الملف الثاني أقل من المرتب في الملف الأول. نفس المرتب: إذا كان المرتب في الملفين متساويًا. محذوف: إذا كان اسم الموظف موجود في الملف الأول ولكن غير موجود في الملف الثاني. جديد: إذا كان اسم الموظف موجود في الملف الثاني ولكن غير موجود في الملف الأول. نتائج المقارنة.xlsb وهذا الملف خاص بمن زادت او نقصت او حذفو او جددفقط بدون نفس المرتب نتائج المقارنة1.xlsb تم تعديل أكتوبر 31 بواسطه عبدالله بشير عبدالله 1 1 رابط هذا التعليق شارك More sharing options...
reem2009a قام بنشر نوفمبر 3 الكاتب مشاركة قام بنشر نوفمبر 3 شكرا جزيلا @عبدالله بشير عبدالله كل الشكر والتقدير وفقك الله 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان