ترحيل أسماء بوجود خلايا مدمجة

[محمد عدنان]

السلام عليكم و رحمة الله و بركاته 

ارجو المساعدة بماكرو يقوم عند احتيار الصفوف يقوم بترحيل الاسماء الى book2 مع الانتباه ان كل صفحة تأخذ 10 اسماء مع الانتباه الى نسلسل الصفحات و ارقامها نجت الجدول 

و شكرا لكم 

قام بمساعدتي للنموذج الاول book الاستاذ الكبير @محي الدين ابو البشر 

 

kutub202022.xlsm

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

😀

تم تعديل ديسمبر 24, 2022 بواسطه محي الدين ابو البشر

[محمد عدنان]

السلام عليكم  

استاذ @محي الدين ابو البشر ارجو المساعدة 

لاني حاولت ما زبط معي بوجود خلايا مدمجة 

اخي الاستاذ @محي الدين ابو البشر ما هو التعديل على الكود ليعمل بوجود خلايا مدمجة 

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

عادة الخلايا المدموجة والأكواد لا يتفقان لذلك.....!!

 

[محمد عدنان]

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

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

فقط استبدل بالكود القديم

Sub Test()
    Dim a, b, x
    Dim i, ii
    Dim nmsht, dt, bk
    Dim p As Long
    Dim ar As Long
    Dim tmp, class, br, mat
    Const c As Integer = 25
    Set nmsht = Sheets("name")
    Set dt = Sheets("data")
    Set bk = Sheets("Book")
    b = dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown)).Resize(, 3)
    p = 4:
    For i = 1 To UBound(b)
        tmp = Split(b(i, 1))
        class = IIf(UBound(tmp) < 3, tmp(1), (tmp(0) & " " & tmp(1)) & " " & tmp(2))
        br = tmp(UBound(tmp)): mat = b(i, 3)
        With nmsht.Range("b2:AX400")
            x = .Find(b(i, 1), , , 1).Address
            a = .Range(x).Offset(3, -1).Resize(.Range(nmsht.Range(x).Offset(3), nmsht.Range(x).Offset(3).End(xlDown)).Count, 2).Offset(-2, -1)
        End With
        ar = 1
        With Sheets("book")
            For ii = 1 To UBound(a) Step c
                x = Split(.[E:E].Find("-" & p & "-", , , 1).Address, "$")(2)
                .Cells(x - 6 - c, 4) = .Cells(x - 6 - c, 4) & " " & class
                .Cells(x - 6 - c, 9) = .Cells(x - 6 - c, 9) & " " & br
                 .Cells(x - 6 - c, 15) = mat
                zzZ = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "")
                For i = 1 To 10
                .Cells(x - 1 - c, 2 + m) = Z(i, 2)
                mm = mm + 4
               Next
                ar = ar + c
                p = p + 2
            Next
        End With
    Next
End Sub

 

الكود أعلاه مع دمج الخلايا

تم تعديل ديسمبر 24, 2022 بواسطه محي الدين ابو البشر

[محمد عدنان]

الاستاذ @محي الدين ابو البشر لنجرب الكود على تسخة بدون خلايا مدمجة للسهولة 

kutub202022 بدون دمج خلايا.xlsm

الاستاذ @محي الدين ابو البشر ما هو حل الخطأ في الرسالة ؟

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

وعليكم السلام 

تفضل أخي الكريم

ولكن أرجو الانتباه إلى أرقام الصفحات يجب أن تمون دائما بالشكل (-12-) عدلت بعضها مثل (-12) أرجو تعديل الباقي

أي استفسار انا جاهز

 

kutub202022 (1).xlsm

[محمد عدنان]

السلام  عليكم و رحمة الله و بركاته 

الاخ الاستاذ @محي الدين ابو البشر  الكود بعد التعديل يعمل جيدا و جزاك الله الجنة 

سقط سهوا الترقيم  للعجلة لم انتبه

استفسار

  1. لماذ لا يظهر الرقم المتسلسل حسب الاسم يعني من 1-10 و الصفحة التي تليها 11-20   و حسب اعداد  الطلبة 

2. اذا ممكن كود مسح النموذج الاستقبال بيانات جديد ( كود مسح ) 

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

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

1- لان الأرقام غير موجودة بالاساس

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

Option Explicit

Sub Test()
    Dim a, b, x, z
    Dim i&, ii&, iii&, mm&
    Dim nmsht, dt, bk
    Dim p As Long
    Dim ar As Long
    Dim tmp, class, br, mat
    Const c As Integer = 10
    Set nmsht = Sheets("name")
    Set dt = Sheets("data")
    Set bk = Sheets("Book")
    b = dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown)).Resize(, 3)
    p = 4:
    For i = 1 To UBound(b)
        tmp = Split(b(i, 1))
        class = IIf(UBound(tmp) < 3, tmp(1), (tmp(0) & " " & tmp(1)) & " " & tmp(2))
        br = tmp(UBound(tmp)): mat = b(i, 3)
        With nmsht.Range("b2:AX400")
            x = .Find(b(i, 1), , , 1).Address
            a = .Range(x).Offset(3, -1).Resize(.Range(nmsht.Range(x).Offset(3), nmsht.Range(x).Offset(3).End(xlDown)).Count, 2).Offset(-2, -1)
        End With
        ar = 1
        With Sheets("book2")
            For ii = 1 To UBound(a) Step c
                x = Split(.[E:E].Find("-" & p & "-", , , 1).Address, "$")(2)
                .Cells(x - 6 - 39, 4) = Split(.Cells(x - 6 - 39, 4))(0) & " " & class
                .Cells(x - 6 - 39, 9) = Split(.Cells(x - 6 - 39, 9))(0) & " " & br
                 z = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c - 1 & "))"), Array(1, 2)), "")
                 For iii = 1 To UBound(z)
                .Cells(x - 1 - 39 + mm, 1) = z(iii, 1)
                .Cells(x - 1 - 39 + mm, 2) = z(iii, 2)
                mm = mm + 4
                Next
                ar = ar + c
                p = p + 2
                mm = 0
            Next
        End With
    Next
End Sub

مرة أخرى (أرقام الصفحات يجب أن تمون دائما بالشكل (-12-) عدلت بعضها مثل (-12) أرجو تعديل الباقي)

إذا كان رقم الصفحة 128- أو -128 سيعطي رسالة خطأ

تم تعديل ديسمبر 26, 2022 بواسطه محي الدين ابو البشر

[محمد عدنان]

الاستاذ @محي الدين ابو البشر  جزاك الله الجنة 

كل الاحترام و التقدير لك و بارك الله في علمك 

و اسف لاني غلبتك 

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

ولا يهمك 

وشكراً لك

[محمد عدنان]

السلام عليكم 

الاخ @محي الدين ابو البشر اشكرك على سرعة الاستجابة و اعتذر عن الاطالة لكن  كود المسح لا يمسح الخلايا التي تقابل الصف و الشعة من حيث ترقيم الصفحات 

السطر البرمجي  .Cells(x - 91, 17) = mat   يجب ان يكون في كود test 

المسح يجب ان يكون حسب تسلسل ترقيم الصفحات 

يعني الاسماء على الصفحات الزوجية  و المادة على الصفحات الفردية حسب التسلسل الترقيمي 

اشكرك  و اسف للازعاج 

ملاحظة الكود ماكرو test يعمل 100%  لا يجب فيه التعديل 

 

 

kutub20-23 -222.xlsm

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

أه الآن  دارت الفكرة آسف لم استوعب الفكرة

عذراً منك

جرب هذا

واعتذر مرة أخرى عن سوء الفهم

kutub20-23 -222.xlsm

تم تعديل ديسمبر 28, 2022 بواسطه محي الدين ابو البشر

[محمد عدنان]

السلام عليكم 

جزاك الله كل خير 

البرنامج يعمل 100%  بفضلك  جزاك الله كل خير و رزقك الله من حيث لا نحتسب 

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

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

الحمد لله 

ولك مثل ما دعوت وأكثر