تكوبن جدول ديناميكي حسب معطيات

[jo0]

السلام عليكم اعضاء المنتدي الاكارم

حفظكم الله ورعاكم من الوياء

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

اريد  ان  يتغير  الجدول اوتوماتيكيا   من حيث الأقسام  و المواد و الأسماء  حسب المعطيات  في  الورقة data  بحيث  يتغير الجدول  تلقائيا  من حيث  عدد  الصفوف ( المواد والأساتذة)  و عدد الاعمدة ( الأقسام)

وشكرا

جدول ديناميكي.xlsx

[بن علية حاجي]

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

كنت أنتظر أن يقوم أحد الإخوة الكرام بإنشاء ماكرو للقيام بهذه العملية وهذا لم يكن، لهذا قمت بتحضير ما تريده في الملف المرفق باستعمال المعادلات... وللضرورة قمت بتغيير التنسيقات على الجداول وإضافة المعادلات المناسبة لعمل المطلوب (يرجى أن لا تقوم بحذف الصفوف أو الأعمدة لئلا تخسر المعادلات)... يبقى لتغييراتك أن تقوم بحجز فقط عدد المناصب -عدد الأساتذة- حسب المواد في "جدول 1" (جدول المواد) وعدد الأفواج -عدد الأقسام- حسب الشعبة والمستوى- في "جدول 2" (جدول الأقسام) والمعادلات تقوم باللازم لملء الجداول الأخرى (حتى الجدول 3 في ورقة Data)... والله أعلم...

جدول ديناميكي.xlsx

[lionheart]

Here's a code but too long. First delete all the cells on the second worksheet then run the macro

Sub Test()
    Const sRow As Integer = 6
    Dim a, ws As Worksheet, sh As Worksheet, v As Long, i As Long, ii As Long, k As Long, c As Long, x As Long, cr As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        With sh.Cells
            .Clear: .UnMerge
        End With
        a = ws.Range("G4:H15").Value
        v = ws.Range("M18").Value
        ReDim b(1 To ws.Range("H16").Value, 1 To v + 2)
        For i = LBound(a) To UBound(a)
            For ii = 1 To a(i, 2)
                k = k + 1
                b(k, 1) = a(i, 1)
                b(k, UBound(b, 2)) = ws.Cells(21 + ii, i + 1).Value
            Next ii
        Next i
        sh.Cells(sRow + 1, v + 2).Value = "Names"
        With sh.Range("A" & sRow + 1)
            .Value = "Subjects"
            .Offset(1).Resize(k, UBound(b, 2)).Value = b
        End With
        a = ws.Range("L4:M17").Value
        ReDim b(1 To 1, 1 To v): k = 0
        For i = LBound(a) To UBound(a)
            For ii = 1 To a(i, 2)
                k = k + 1
                b(1, k) = a(i, 1) & IIf(a(i, 2) > 1, Space(1) & CStr(ii), Empty)
            Next ii
        Next i
        sh.Range("B" & sRow + 1).Resize(, k).Value = b
        a = ws.Range("N4:N17").Value
        c = 2
        For i = LBound(a) To UBound(a)
            If Not IsEmpty(a(i, 1)) Then
                x = x + 1
                Select Case x:
                    Case 1: cr = RGB(255, 255, 0)
                    Case 2: cr = RGB(248, 203, 173)
                    Case 3: cr = RGB(169, 208, 142)
                End Select
                With sh.Cells(sRow, c)
                    .Value = x
                    .Resize(, a(i, 1)).Merge
                    .Resize(, a(i, 1)).Interior.Color = cr
                    .Offset(1).Resize(, a(i, 1)).Interior.Color = cr
                End With
                c = c + a(i, 1)
            End If
        Next i
        With sh
            .Cells.ReadingOrder = xlRTL
            .Cells.HorizontalAlignment = xlCenter
            .Cells.VerticalAlignment = xlCenter
            With .Range("A" & sRow).CurrentRegion
                .Font.Name = "Times New Roman"
                .Font.Size = 14: .Font.Bold = True
                .Borders.Value = 1
                .Rows.RowHeight = 18
                .Columns.ColumnWidth = 8.43
                .Columns(1).ColumnWidth = 14.5
                With .Columns(.Columns.Count)
                    .ColumnWidth = 14.5
                    .Interior.Color = RGB(255, 192, 0)
                    .Cells(1).Interior.Color = xlNone
                End With
            End With
        End With
    Application.ScreenUpdating = True
End Sub

 

[هشام جودي]

السلام عليكم 

عند استعمال الماكرو لا يعمل عند السطر التالي

Debogage

ReDim b(1 To ws.Range("H16").Value, 1 To v + 2)

 

[lionheart]

The code is working on the attached file