اذهب الي المحتوي
أوفيسنا

محي الدين ابو البشر

الخبراء
  • Posts

    877
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    6

كل منشورات العضو محي الدين ابو البشر

  1. الحمد لله ولك الشكر في حدث الصفحة (Sheet code) يوجد ماكرو يعمل فقط عند تغير الرقم(Sheet code)
  2. ربما بناء على رقمكم (رقمنا) ترحيل بيانات للنموذج.xlsm أو بالمعادلات ترحيل بيانات للنموذج.xlsx
  3. والسلام عليكم ورحمة الله وبركاته هل تقصد شيء كهذا؟؟!! aBoo.xlsm
  4. أخي الكريم عملت على الملف الأول ولم انتبه إلى تعديل الملف على كل جرب هذا عسى يكون المطلوب Double Dlick على إي خلية في العمود E (رقم ملف الحالة) سوف يظهر التقرير الخاص ... Book2.xls
  5. يمكن تعديل السطر ReDim a(1 To 100, 1 To 2) إلى ReDim a(1 To 1000, 1 To 2) و أخبرني بالنتيجة بالتوفيق
  6. هذا آخر ملف لك مع الكود المنقح ويعمل جيداً بعد الأخذ بعين الاعتبار الملاحظة التالية إذا سمحت لي: حسب العمود الأول لديك دائما تبدأ بـ اسم المدرسة ثم "المدرسة" ، أرقام الكتتاب ثم "رقم الاكتتاب" ..... وفي النهاية الديانات ثم "الديانة" هذا الكلام جميل ولا غيار عليه ولكن لا أدري لماذا في بعض المدارس يختلف الترتيب في الديانات "الديانة" ثم الديانات جرب الملف المرفق مع التعديل عسى يناسبك تحويل عمود 4 معدل.xlsm
  7. من الصورة أعلاه يبدو أنها غير الملف الذي ارسلته في المشاركة الأولى!!! مع العلم أن الكود يعمل على ملفك جيداً أو ممكن أن نحاول استبدال السطر With Columns(1)بـWith [a:a]
  8. وعليكم السلام ورحمة الله وبركاته ربما Sub Test() Dim x, h Dim i&, c& Dim ar As Range With [a:a] .ClearContents .Interior.Color = xlNone End With h = Range("f1").Resize(, 9) For Each ar In Range("F1").CurrentRegion.SpecialCells(4).Areas x = ar.Offset(-1).Resize(ar.Count + 1, 9) For i = 2 To UBound(x, 2) If i = 2 Then Cells(3, 17).Offset(c) = IIf(i = 2, x(i - 1, 1), h(1, i - 1)) With Cells(3, 1) .Offset(c + 1) = h(1, i - 1) .Offset(c + 1).Interior.Color = vbYellow .Offset(c + 2).Resize(UBound(x)) = Application.Index(x, Evaluate("row(1:" & UBound(x) & ")"), i) End With c = c + UBound(x) + 1 Next Cells(3, 1).Offset(c + 1) = h(1, i - 1) c = c + 2 Next End Sub
  9. حسناً يجب أخذ في عين الإعتبار وجود نفس القيمة مكررة في أكثر من خلية مع أني لا أعتقد ذلك بحسب المعادلة التي وضعها السيد مشعل لكن بكل الأحوال ممكن تجربة هذا الكود Sub test() Dim i& Dim x As String Dim r As Range Application.ScreenUpdating = False Range("A1:AI35").Interior.Color = xlNone For i = 14 To 15 With Range("A1:AI35") Set r = .Cells.Find(Range("AL" & i), , , 1) x = r.Address Do r.Interior.Color = vbRed Set r = .Cells.FindNext(r) Loop Until r.Address = x End With Next Application.ScreenUpdating = True End Sub 'وأيضاً لتلوين كل رقم بلون مختلف Sub test2() Dim i& Dim x As String Dim r As Range Dim f As Boolean Application.ScreenUpdating = False Range("A1:AI35").Interior.Color = xlNone For i = 14 To 15 With Range("A1:AI35") Set r = .Cells.Find(Range("AL" & i), , , 1) x = r.Address Do r.Interior.Color = IIf(f, vbRed, vbYellow) Set r = .Cells.FindNext(r) Loop Until r.Address = x End With f = True Next Application.ScreenUpdating = True End Sub
  10. بالاذن من الاستاذ محمد هشام. طريقة أخرى Sub test() Range("A1:AI35").Interior.Color = xlNone For I = 14 To 15 Range("A1:AI35").Cells.Find(Range("AL" & I), , , 1).Interior.Color = vbRed Next End Sub
  11. السلام عليكم حسب ما فهمت من الملف المرفق من قيبل السيد sabah2023 هناك سوء فهم بتعبير الصفحة لذلك اقترح الكود التالي Sub test() Dim i& For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 27 Rows(i & ":" & i + 1).RowHeight = 30 Rows(i + 2 & ":" & i + 26).RowHeight = 20 Next End Sub
  12. عليكم السلام (اظهار الكودات بالخانات بالاخضر على أساس ما محدد باللون الأصفر) غير مفهوم
  13. عليكم السلام إذا كنت منفتحاً على استخدام ماكرو فإليك هذا وإلا .... Sub test() Dim a, w Dim T As String Dim i& a = Sheets("aaa").Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) T = a(i, 2) & a(i, 3) & a(i, 4) If Not .exists(T) Then .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4), a(i, 1), a(i, 1) + IIf(a(i, 1) = 1, 199, 99)) Else w = .Item(T): w(5) = w(4) + 99: .Item(T) = w End If Next Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2) + 2) = Application.Index(.items, 0, 0) End With End Sub
  14. Sub test() Dim a, x Dim i&, ii& Application.ScreenUpdating = False a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1 If Not .exists((Cells(i, ii).Value)) Then Cells(i, ii).Interior.Color = vbRed Else Cells(i, ii).Interior.Color = 16777164 End If Next: Next End With Application.ScreenUpdating = True End Sub Sub tes2() Dim a, x x = Cells(1, 9).CurrentRegion.Columns.Count Dim i&, ii& Application.ScreenUpdating = False With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1 If Not .exists((Cells(i, ii).Value)) Then Cells(i, ii).Interior.Color = vbYellow Else Cells(i, ii).Interior.Color = 16777164 End If Next: Next End With Application.ScreenUpdating = True End Sub
  15. تفضل أخي الكريم Sub test() Dim a, w, x, k Dim i&, ii& a = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 5 To UBound(a) If Not .exists(a(i, 9)) Then .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), a(i, 10) & " NO - " & Format(a(i, 7), "0#")) Else w = .Item(a(i, 9)) x = Split(w(3), "-") If UBound(x) > 0 Then w(3) = x(0) & "- " & Format(a(i, 6), "0#") .Item(a(i, 9)) = w Else x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#") w(3) = Join(x) .Item(a(i, 9)) = w End If: End If Next For Each k In .keys Cells(5 + ii, 14).Resize(5) = Application.Transpose(.Item(k)) ii = ii + 6 Next End With End Sub
  16. Sub test() Dim a Dim i& a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbRed Else Cells(i, 9).Interior.Color = xlNone End If Next End With End Sub --------------------- Sub tes2() Dim a Dim i& With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbYellow Else Cells(i, 9).Interior.Color = xlNone End If Next End With End Sub ماكرو عادي يتم تنفيذه من قبلك
×
×
  • اضف...

Important Information