ياسر خليل أبو البراء

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

وهذا ملف للأستاذ الكبير محمد الريفي بالمعادلات إثراءً للموضوع

Transpose Rows And Columns.rar

جرب الكود التالي لعله يفي بالغرض (ومن غير شريط تقدم هيكون سريع إن شاء الله)

Sub Test()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim arr     As Variant
    Dim temp    As Variant
    Dim i       As Long
    Dim j       As Long
    Dim p       As Long
    Dim sW      As Double
    Dim sM      As Double
    
    Set ws = Sheets("Data")
    Set sh = Sheets("Report")

    arr = ws.Range("B2").CurrentRegion.Value
    ReDim temp(1 To UBound(arr, 1), 1 To 2)

    For i = 2 To UBound(arr, 1)
        If arr(i, 2) <> "" Or arr(i, 3) <> "" Then
            p = p + 1
            temp(p, 1) = arr(i, 1)
            sW = sW + Val(arr(i, 2))
            sM = sM + Val(arr(i, 3))
            temp(p, 2) = sW - sM
        End If
    Next i

    With sh
        .Columns("E:F").ClearContents
        .Range("E3:F3").Value = Array("التاريخ", "الرصيد التراكمي")
        .Range("E4").Resize(p - 1, UBound(temp, 2)).Value = temp
    End With
End Sub

أليس الموضوع مكرر أم أن الطلب مختلف هنا في الموضوع؟؟!!

الكود مشروح في الأساس من قبل أخونا ياسر العربي .. والإضافات في الكود بسيطة ولا تحتاج لشرح حيث تم الاستعانة بدالة معرفة لمعرفة آخر صف مستخدم في ورقة العمل ، ودالة أخرى لمعرفة آخر عمود مستخدم في ورقة العمل .. وعلى أساس معرفة رقم آخر صف وآخر عمود يتم المسح والنسخ ..

أخي الكريم ناصر

والله لقد قمت بشرح الكثير والكثير من الأكواد ولكن بلا فائدة وهذا لا يعني أنني يأست .. ولكن المشكلة أنه لا يوجد همة للتعلم

معظم من يرتاد الموقع يريد أن يقضي طلبه وفقط ولا يريد التعلم ... والله المستعان

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

الحمد لله الذي بنعمته تتم الصالحات

بالنسبة للشرح أفضل إن اللي عايز يتعلم يحاول يدرس الكود يونفذه سطربسطر ولو وقف في جزئية مش فاهمها يسأل عنها ..

وعلى رأي المثل اللي بيقول Come easy go easy >> 

جرب اعمل كليك يمين على زر الـ Spin ثم Assign Macro ... وحول الماكرو الموجود لماكرو عادي في موديول عادي

امسح الماكرو الموجود في حدث ورقة العمل ، وضع الكود التالي في موديول .. واعمل كليك يمين Assign Macro واختر اسم الماكرو Test ... لربط الزر بتنفيذ الكود

Sub Test()
    Dim s As Worksheet
    Dim t As Worksheet
    Dim v As Variant
    Dim r As Long

    Set s = Sheets("تسجيل البيانات")
    Set t = Sheets("الكشوف النهائية")
    v = t.Range("P1").Value

    If Not IsNumeric(v) Or IsEmpty(v) Or v > 4 Then t.Range("B14").Resize(6, 4).ClearContents: Exit Sub
    r = (v * 6) + 5

    t.Range("B14").Resize(6, 4).Value = s.Range("A" & r).Resize(6, 4).Value
End Sub

وعليكم السلام أخي محمد

جرب الكود التالي

Private Sub UserForm_Initialize()
    Label2 = Application.WorksheetFunction.COUNTA(Range("B2:B200"))
End Sub

لم أفهم المشكلة للآن .. الكود يقوم بعملية المسح بداية من الصف رقم 8 وإلى آخر رقم صف .. ورقم الصف متغير من ورقة لأخرى ..

حاول توضح المشكلة بالصور لكي أفهم أين الخلل؟؟!

بعد الإطلاع على الملف .. وبشغل التخمين جرب السطر التالي .. ابحث عنه في الكود واستبدله بهذا السطر

sh.Range("A8").Resize(Rows.Count - 7, lc).Clear

ولكن هذا سيستغرق وقت أطول بقليل .. من المفترض أن تقوم بضبط الملف لأول مرة بشكل يدوي بحيث لا يكون هناك خلايا بها تنسيق .. عموماً ممكن بعد تنفيذ الكود بهذا السطر الجديد يمكنك استخدام السطر القديم لأنه لن تكون بحاجة إلى مسح كل هذا الكم من الصفوف .. هذا والله أعلم

نعم المعطيات واضحة والنتائج المتوقعة واضحة ..

سأحاول العمل على الأمر بشكل أعمق في أقرب وقت .. وأعتقد لو تدخل الأخ سليم سيحل الأمر يسهولة لأنه متمكن عني في التعامل مع القوائم المنسدلة

في الحقيقة اطلعت ولم أوفق في حل المشكلة ..

أنا لا أتردد عن المشاركة إذا كان لدي علم بالأمر .. فلا تحزن من عدم مشاركتي !

اعمل كليك يمين على الأداة Spinner وستجد أمر Format Control وفي آخر تبويب ابدأ في التعامل .. وحدد الخلية المطلوب ربطها بالأداة Link Cell ...

في الملف المرفق الجديد أيضاً قم بتعديل نفس السطر

If Intersect(Range("A1:D1"), Target) Is Nothing Then

بصراحة المشكلة في إني مش بقدر افهم المطلوب بشكل كويس .. ولذلك يفضل وضع صورة بالمطلوب .. ضع المعطيات وشكل النتائج المتوقعة في صورة أفضل حتى يسهل التواصل فيما بيننا 

أخي العزيز ناصر 

جرب الكود التالي عله يفي بالغرض ... امسح الأكواد الموجودة في الموديولات لأن هناك كودين بنفس الاسم Test وهذا لا يجوز ..

ضع الكود التالي في حدث الفورم بعد مسح الكود القديم ، والشكر موصول للأخ الغالي ياسر العربي صاحب الفكرة الرائعة

Private Sub CommandButton1_Click()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim c       As Long
    
    Set ws = Sheets("بيانات الطلبة")
    c = ws.Range("Q1").Value
    
    If TextBox1.Text = ws.Range("F1") Then
        Me.Hide
        TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64
        
        Application.ScreenUpdating = False
        Application.Calculation = xlManual
            If ws.Range("Q1") < 2 Then
                Exit Sub
            End If
            
            For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "كشف ناجح"))
                lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh))
                lc = LastOccupiedColNum(sh)
                
                sh.Range("A8").Resize(lr + 7, lc).Clear
                sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").Resize(c, lc)
            Next sh
            
            Application.Goto ws.Range("A1")
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
        Unload Me
    Else
        MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation
        TextBox1.Text = ""
        TextBox1.SetFocus
    End If
End Sub

Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedRowNum = lng
End Function

Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedColNum = lng
End Function

وجزيت خيراً بمثل ما دعوت لي ..

ولا يهمك بخصوص نسيان سنفرة الملف ..المهم بعد كدا تسنفر بالك ..

تقبل تحياتي

غير السطر التالي

If Intersect(Range("A1:D1"), Target) Is Nothing Then

أخي الكريم يبدو أن الخطأ من عندي ..

في هذا السطر

If Target.Address = "$G$1" Then

استبدل حرف الـ G بحرف الـ P

أو يمكنك تجربة الكود كما هو وقم بإدخال رقم المجموعة في الخلية G1

هل اطلعت على المشاركة السابقة والملف المرفق .. لأنك لم تعلق عليه ، حاول أن تتبع نفس الأسلوب

في ورقة العمل "كنترول شيت" وورقة العمل "كنترول شيت (2)" وورقة العمل "رصد الترم الأول" وورقة العمل "Sheet1" ليسوا بنفس الهيكلة أي أن البيانات لا تبدأ من الصف السابع كبقية الأوراق . فهل هذه أوراق سيتم استثنائها؟

ولما لا ترفق نموذج مصغر كالذي أرفقته ليسهل العمل عليه .. اطلع على المرفق أعلاه في المشاركة السابقة وفيه نفس الفكرة حيث يتم عمل حلقة تكرارية لأوراق العمل ثم يتم تحديد رقم آخر عمود بناءً على وجود متغير يتم مقارنته في كل مرة مع رقم آخر عمود بالورقة التي عليها الدور في الحلقة التكرارية

أخي الكريم محمود

بالمثال يتضح المقال .. ضع ملف مرفق بسيط موضحاً فيه المطلوب 

ارفق الملف الذي قمت بوضع الكود لمعرفة الخلل

أخي الكريم الموضوع بسيط

اعمل كليك يمين على اسم ورقة العمل المسماة "الكشوف النهائية" .. واختر الأمر View Code .. وانسخ الكود من المشاركة (بس خلي اتجاه لغة الكتابة باللغة العربية عند النسخ) ، وبعدين روح للنافذة اللي اتفتحت والصق الكود وبس خلاص

الكود هيتنفذ بمجر وضع رقم في الخلية P1 في ورقة "الكشوف النهائية" ..

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

دعك من تحميل الملف

المهم الكود .. استخدم الكود الموجود في الموضوع .. الملف ما هو إلا مثال تطبيقي على الكود

Sub Create_PDF_Files_For_Each_Sheet()
    Dim Ws As Worksheet
    Dim Fname As String
    
    Application.ScreenUpdating = False
        For Each Ws In ActiveWorkbook.Worksheets
            On Error Resume Next
            Fname = ThisWorkbook.Path & "\Exported " & Ws.Name
            Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fname, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
        Next Ws
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

أخي الكريم محمد

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

ولو فيه أي استفسار لا تترد .. حاول تطلع على الموضوع من أول حلقة كنوع من التعلم في نفس الوقت وستجد الموضوع ممتع إن شاء الله

أخي الكريم نوري

هل هو نفس طلبك في الموضوع السابق أم موضوع مختلف

لو كان موضوع مختلف ارفق ملف ليساعدك الأخوة الكرام بالمنتدى

تقبل تحياتي

نعم أخي الكريم

عموماً رأيت اليوم مقال يخص طلبك لربما يفيدك ..حاول الإطلاع عليه وإن شاء الله تقدر تستفيد منه

https://www.myonlinetraininghub.com/clear-downstream-dependent-data-validation-lists