spyhearts قام بنشر يوليو 1 مشاركة قام بنشر يوليو 1 السلام عليكم ورحمه الله وبركاته كل عام واسرة المنتدى العظيم بخير وسعادة امل المساعدة في عمل مقارنة بين ورقتين لعدد اعمدة معين مرفق الملف الاعندة باللون الاصفر اريد المقارنة بينهم ووضع الاختلافات في ورقة النتائج ولكم جزيل الشكر مقارنة اعمدة معينة على ورقتين.xlsx رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر يوليو 2 أفضل إجابة مشاركة قام بنشر يوليو 2 وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Extract_The_differences() '================02/07/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Dim a(1), b, i&, arr&, n&, x&, lr&, dic As Object Set dic = CreateObject("Scripting.Dictionary") Dim srcWS As Worksheet: Set srcWS = Sheets("النتائج") rCrit = [{1,2,12,13,14,18}] ''<======= ' تحديد اعمدة المقارنة With Sheets("2023") With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18) a(0) = Application.Index(.Value, _ Evaluate("row(2:" & .Rows.Count & ")"), rCrit) End With End With For i = 1 To UBound(a(0), 1) dic(a(0)(i, 1)) = Array(i, Join(Application.Index(a(0), i, 0), Chr(2))) Next With Sheets("2022") With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18) a(1) = Application.Index(.Value, _ Evaluate("row(2:" & .Rows.Count & ")"), rCrit) End With End With ReDim b(1 To UBound(a(1), 1), 1 To UBound(a(1), 2) * 2 + 2) For i = 1 To UBound(a(1), 1) If dic.exists(a(1)(i, 1)) Then If dic(a(1)(i, 1))(1) <> Join(Application.Index(a(1), i, 0), Chr(2)) Then n = n + 1 For arr = 1 To UBound(a(1), 2) b(n, arr) = a(1)(i, arr) b(n, arr + UBound(b, 2) / 2) = a(0)(dic(a(1)(i, 1))(0), arr) If b(n, arr) <> b(n, arr + UBound(b, 2) / 2) Then b(n, UBound(b, 2)) = b(n, UBound(b, 2)) + 1 End If Next End If End If Next With srcWS Application.ScreenUpdating = False With .Rows("5:" & .Cells.SpecialCells(11).Row) .ClearContents: .Interior.ColorIndex = xlNone End With If n Then .[A5].Resize(n, UBound(b, 2)) = b '[تنسيق الاختلافات] On Error Resume Next With .Rows(4).SpecialCells(2).Areas(2) With .CurrentRegion.Resize(, .Columns.Count - 1) .FormatConditions.Delete .FormatConditions.Add 2, Formula1:="=" & .Cells(1).Address(0, 0) & "<>A4" .FormatConditions(1).Interior.Color = RGB(255, 204, 0): Set Rng = srcWS.[N5:N1000] On Error GoTo 0 End With End With End If End With Application.ScreenUpdating = True MsgBox Application.WorksheetFunction.Sum(Rng) & _ " " & ": عدد الاختلافات", vbInformation, " مقارنة 2022 / 2023 " End Sub مقارنة اعمدة معينة على ورقتين.xlsm 2 رابط هذا التعليق شارك More sharing options...
spyhearts قام بنشر يوليو 2 الكاتب مشاركة قام بنشر يوليو 2 ماشاء الله ربنا يبارك في حضرتك ا. محمد هو المطلوب ربما يزيدك من علمه ويوفقك في مساعدة الزملاء رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان