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

Sub Transfer() Dim rg As Range With Sheets("ورقة1") Set rg = .Range(.Range("A1:D1"), .Range("A1:D1").End(xlDown)) With rg .AutoFilter Field:=1, Criteria1:="منفذ" .Offset(1).Copy Sheets("ورقة2").Range("A2") .AutoFilter End With End With End Sub

الحمد لله ولك الشكر في حدث الصفحة (Sheet code) يوجد ماكرو يعمل فقط عند تغير الرقم(Sheet code)

ربما بناء على رقمكم (رقمنا) ترحيل بيانات للنموذج.xlsm أو بالمعادلات ترحيل بيانات للنموذج.xlsx

=FLOOR(B2,250) أو =FLOOR(B2;250) ???????????

والسلام عليكم ورحمة الله وبركاته هل تقصد شيء كهذا؟؟!! aBoo.xlsm

سلف الديار.xlsx

بارك الله

أخي الكريم عملت على الملف الأول ولم انتبه إلى تعديل الملف على كل جرب هذا عسى يكون المطلوب Double Dlick على إي خلية في العمود E (رقم ملف الحالة) سوف يظهر التقرير الخاص ... Book2.xls

يمكن تعديل السطر ReDim a(1 To 100, 1 To 2) إلى ReDim a(1 To 1000, 1 To 2) و أخبرني بالنتيجة بالتوفيق

هذا آخر ملف لك مع الكود المنقح ويعمل جيداً بعد الأخذ بعين الاعتبار الملاحظة التالية إذا سمحت لي: حسب العمود الأول لديك دائما تبدأ بـ اسم المدرسة ثم "المدرسة" ، أرقام الكتتاب ثم "رقم الاكتتاب" ..... وفي النهاية الديانات ثم "الديانة" هذا الكلام جميل ولا غيار عليه ولكن لا أدري لماذا في بعض المدارس يختلف الترتيب في الديانات "الديانة" ثم الديانات جرب الملف المرفق مع التعديل عسى يناسبك تحويل عمود 4 معدل.xlsm

لم تذكر ما هي التغييرات مع ذلك تحويل عمود (1).xlsm

عسى يكون المطلوب تحويل عمود (1).xlsm

فهمت الموضوع غلط آسف عل الـ MIS UNDERSTANGIG

تحويل عمود .xlsm

من الصورة أعلاه يبدو أنها غير الملف الذي ارسلته في المشاركة الأولى!!! مع العلم أن الكود يعمل على ملفك جيداً أو ممكن أن نحاول استبدال السطر With Columns(1)بـWith [a:a]

وعليكم السلام ورحمة الله وبركاته ربما 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

حسناً يجب أخذ في عين الإعتبار وجود نفس القيمة مكررة في أكثر من خلية مع أني لا أعتقد ذلك بحسب المعادلة التي وضعها السيد مشعل لكن بكل الأحوال ممكن تجربة هذا الكود 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

بالاذن من الاستاذ محمد هشام. طريقة أخرى 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

بارك الله

السلام عليكم حسب ما فهمت من الملف المرفق من قيبل السيد 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

عليكم السلام (اظهار الكودات بالخانات بالاخضر على أساس ما محدد باللون الأصفر) غير مفهوم

عليكم السلام إذا كنت منفتحاً على استخدام ماكرو فإليك هذا وإلا .... 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

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

تفضل أخي الكريم 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

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 ماكرو عادي يتم تنفيذه من قبلك