ترحيل متعدد للصفوف و الشعب

[محمد عدنان]

السلام عليكم 

ارجو المساعدة في  ترحيل متعدد و اختيار الصفوف من صف واحد و لغاية 24  من خلال شيت data من الخلايا b4, b5,b6...........b27

ثم الضغط على زر ترحيل الى شيت book حسب الترقيم اسفل الجدول 

الكود التالي كنب بمساعدة الاخ @hassona229 , و له جزيل الشكر و يقوم بترحيل صف واحد 

Sub Test()
    Const nRows As Long = 25
    Const sCells As String = "b39,b103,b167,b231,b295,b359,b423,b487,b551,b615,b679,b6,b71,b135,b199,b263,b327,b391,b455,b519,b583,b647"
    Dim x, a, t, ws As Worksheet, sh As Worksheet, wsdata As Worksheet, rng As Range, r As Range, lr As Long, n As Long, i As Long, m As Long, ii As Long
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("Name")
    Set sh = ThisWorkbook.Worksheets("book")
    Set wsdata = ThisWorkbook.Worksheets("data")
    sh.Range("a6:b30,a39:b63,a71:b95,a103:b127,a135:b159,a167:b191,a199:b223,a231:b255,a263:b287,a295:b319,a327:b351,a359:b383,a391:b415,a423:b447,a455:b479,a487:b511,a519:b543,a551:b575,a583:b607,a615:b639,a647:b671,a679:b703").ClearContents
    x = Application.Match(wsdata.Range("b4").Value, ws.Rows(2), 0)
    If Not IsError(x) Then
        lr = ws.Cells(Rows.Count, x).End(xlUp).Row
        If lr < 4 Then MsgBox "No Data", vbExclamation: Exit Sub
        Set rng = ws.Range(ws.Cells(5, x - 1), ws.Cells(lr, x))
        a = rng.Value
        n = UBound(Split(sCells, ",")) + 1
        For i = 1 To n
            Set r = sh.Range(Split(sCells, ",")(i - 1))
            t = Application.Index(a, Evaluate("(Row(" & m + 1 & ":" & m + nRows - 1 + 1 & "))"), Array(1, 2))
            m = m + nRows
            For ii = UBound(t) To LBound(t) Step -1
                If IsError(t(ii, 1)) Then
                    t(ii, 1) = Empty
                    t(ii, 2) = Empty
                Else
                    Exit For
                End If
            Next ii
            r.Offset(0, -1).Resize(UBound(t), 2).Value = t
            Set r = Nothing
        Next i
    End If
      Application.ScreenUpdating = True
End Sub

الملف في المرفق 

كتيب العلامات 2022.xlsm

[محمد عدنان]

السلام عليكم

ارجو اعتماد هذا النموذج كتيب العلامات 2022-2معدل.xlsm

تم التعديل على ارقام الصفحات 

ارجو الانتباه لارقام الصفحات اسفل الجدول 

عند الطباعة سيصبح على شكل كتاب  مع الانتباه للترقيم 

هل من مساعدة في جعل الماكرو يقرا من الخلية b4 و لغاية b27 ثم يقوم باستدعاء اسماء الطلاب و ترحيلها مع مراعاة ترقيم الصفحات اسفل الجدول في شيت book ? 

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

السيد محمد عدنان 

ممكن أن ترفع بعض النتائج في شيت book  مثلا للعاشر أ والحادي عشر ب (أن تملاها يدويا)

شكراً

[محمد عدنان]

السلام عليكم 

اشكرك اخي @محي الدين ابو البشر على اهتمامك بالموضوع 

ارفق ملف معبأ يدوي حسب الاختيار من  شيت data  يعد ان يتم اختيار الصفوف و الشعب ( يمكن يكون الاختيار اكثر من 5 صفوف ) 

يتم الضغط على زر ترحيل الى شيت book مع الانتباه لترقيم الصفحات 

الترحيل يتم الى اسفل للصفحات  الزوجية و عند الوصل الى صفحة 30 يصبح الترحيل زوجي لكن صعودا  في صفحة book  الغاية من ذلك الطباعة على شكل كتيب 

و شكرا لك و للجميع و اتمى اني قد اوجزت في الشرح  و المساعدة 

اخ @محي الدين ابو البشر  مع ملاحظة ان اعداد الطلبة متغيرة 

كتيب العلامات 2022-2معدل مثال.xlsm

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

تفضل أخي

عسى يكون المطلوب

Sub Test()
    Dim a, b, x
    Dim i, ii
    Dim nmsht, dt, bk
    Dim p As Long
    Dim ar As Long
   Const c  As Integer = 25
    Set nmsht = Sheets("name")
    Set dt = Sheets("data")
    Set bk = Sheets("Book")
    b = Application.Transpose(dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown)))
    p = 4:
    For i = 1 To UBound(b)
        With nmsht.Range("b2:AX400")
            x = .Find(What:=b(i), After:=Range("B2"), lookat:=xlWhole, SearchDirection:=xlNext).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 25
                x = Split(.[E:E].Find(What:="-" & p & "-", After:=Range("E2"), lookat:=xlWhole, SearchDirection:=xlNext).Address, "$")(2)
                .Cells(x - 1 - c, 1).Resize(c, 2) = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "")
                ar = ar + c
                p = p + 2
            Next
        End With
    Next
End Sub

 

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

[محمد عدنان]

السلام عليكم 

الاخ @محي الدين ابو البشر  جزاك الله خير الجزاء 

تم وضع  الكود و قام بترحيل الاسماء و سيتم التأكد من الترحيل عند وضع اسماء طلبة حقيقية 

ملاحظة

1. في اعلى الجدول هل بالامكان  ترحيل اسم الصف و الشعبة بناءاً على الاختيار  من صفحة data

2. ماكرو لمسح الاسماء  من  الجدول   لاعداد  خيارات صفوف اخرى 

3. ظهر الرقم صفر و 45 عند ترحيل اخر الصف الثاني الادبي ز  و لم يرحل الاسماء كاملة تاقصة اسم واحد

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

اسأل الله العظيم ان يمتعكم بالصحة و العافية 

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

عليكم السلام 

بالنسبة للملاحظة 3

الكود يعمل بشكل صحيح حسب آخر ملف أرسلته "مثال معدل"

على كل تانظر المرفقوأعلمني

بالنسبة للملاحظات 1و2 ساعمل عليها بإذن الله 

 

كتيب العلامات2.xlsm

[محمد عدنان]

السلام  عليكم 

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

بالنسبة للملاحظة 3 هي فقط للصف الثاني عشر ز  اخر صف قمت باضافة صف  في اخر جدول 

اما باقي الكود يعمل بشكل ممتاز 

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

 

سؤال هل يوجد ماكرو يقوم بطلب بعد ترحيل الاسماء بحفظ شيت book لوحدها  ؟

اكرر شكري لك و في ميزان حسناتك 

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

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

كتيب العلامات2.xlsm

 

[محمد عدنان]

السلام عليكم 

الكود يعمل بشكل ممتاز 

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

بقي ماكرو المسح و شكرا لك 

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

[محمد عدنان]

السلام عليكم 

شكرا لك   لكن لا يمسح الصف و الشعبة 

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

آسف جدا .. My mistack

كتيب العلامات2.xlsm

[محمد عدنان]

السلام عليكم 

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

في ميزان حسناتك 

 

 

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

لا صورة

سأبقى معك حتى تحل كل المشاكل

؟؟؟؟؟؟؟؟؟؟؟

 

[محمد عدنان]

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

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

جزاك الله كل خير .. تم حل جميع المشاكل 

و بقي ترحيل اسم المادة  من عمود مخفي بجانب الصفوف من شيت data فقط 

 ماهي الاسطر من الكود التي يجب اضافتها ؟ 

 

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

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

 

ترحيل اسم المادة!!! ليس بإضافة أسطر

خيراً إن شاء الله

[محمد عدنان]

يتم وضع اسم المادة  في عمود بحانب اسم الصف 

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

استبدل الاكواد

Option Explicit

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
                .Cells(x - 1 - c, 1).Resize(c, 2) = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "")
                ar = ar + c
                p = p + 2
            Next
        End With
    Next
End Sub

و

Private Sub CommandButton1_Click()
    Dim r As Range
    With Sheets("Book")
        On Error Resume Next
        For Each myArea In .Columns(1).SpecialCells(2, 1).Areas
            myArea.Resize(, 2).ClearContents
            myArea.Offset(-5, 3).Resize(1) = Split(myArea(-4, 4))(0)
            myArea(-4, 9) = Split(myArea(-4, 9))(0)
            myArea(-4, 15) = ""
        Next
    End With
End Sub

 

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

بارك الله

[محمد عدنان]

السلام عليكم 

الاخ @محي الدين ابو البشر جزاك الله كل خير 

الكود يعمل بشكل ممتاز 

كل الاحترام لك و لجميع من ساهم في المساعدة في حل الملف