سؤال بسيط من مبتدئ بخصوص pivot table

[Hussein888]

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

سؤال بسيط لكن للاسف انا معلوماتي ف اكسيل تكاد تكون زيرو ف ارجو المساعدة.. 

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

عمود (اليوم) ايام الشهر لاخره

عمود (التاريخ) ايام الشهر بالتاريخ من 1 الى 30

عمود مخزن 1 

عمود مخزن 2 

عمود مخزن 3 

عمود مخزن 4

تحت اعمدة المخازن الاربعة اسماء الاشخاص المنوط بهم القيام بالوردية لمدة 24 ساعة.. 

المطلوب بعد ما اكتب الجدول بالطريقة دي يتم تدوير البيانات بحيث 

يكون رؤوس الاعمدة هي الايام و التاريخ 

و الصفوف هي اسماء العاملين 

و القيم اسفل كل عمود من ايام الشهر هي رقم المخزن كالشكل الاتي.. (قمت بالتدوير يدويا) 

و شكرا جزيلا لكم

[محمد هشام.]

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

1) يصعب التعامل مع الصور اخي الكريم المفروض إرفاق ملف للاشتغال عليه 

2)  الصورة المرفقة  للنتائج المطلوبة تتضمن فقط مخزن 1 ومخزن 2 اين هو 3 و4 

3) عدم تحديد مكان وضع النتائج 

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

 

 

تم تعديل بالامس في 01:25 بواسطه محمد هشام.

[Hussein888]

استاذ محمد هشام تحياتي لحضرتك 

اللي حضرتك ارسلته هو بالضبط المطلوب 

بعتذر عن عدم استكمال البيانات في الصورة الثانية لاني عملتها يدويا بايدي و كان في صعوبة ف استخلاص البيانات.. ف عملت مخزن 1 و مخزن 2 فقط و ماكملتش.. 

حضرتك عملت المطلوب تماما.. ياريت تديني شرح للطريقة و شكرا جزيلا 🌹

[محمد هشام.]

تم تنفيذها بواسطة كود vba 

يرجى إرفاق عينة لشكل البيانات لديك لتحديد النطاقات بشكل صحيح

ومكان وضع النتائج المطلوبة تفاديا للأخطاء 

[Hussein888]

طيب لو في امكانية تكتبلي الكود وانا احاول اطبقه 

[محمد هشام.]

إدن لنفترض أننا سنقوم باستخراج البيانات من الأعمدة  H:M   كما هو ظاهر لديك على الصورة إلى ورقة 2 مثلا 

Sub CreateShift()
    Dim lastRow As Long, i As Long, j As Long, kay As String, c As String
    Dim tbl As Variant, Names As Collection, cell As Range, name As String
    
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    Dim dest As Worksheet: Set dest = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear

    lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row
    tbl = WS.Range("H4:M" & lastRow).Value

    For i = 1 To lastRow - 3
        dest.Cells(1, i + 1).Value = tbl(i, 2)
        dest.Cells(2, i + 1).Value = tbl(i, 1)

        If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then
            Colors dest.Cells(1, i + 1), RGB(200, 200, 255)
            Colors dest.Cells(2, i + 1), RGB(255, 153, 0)
        End If
    Next i

    Set Names = New Collection
    On Error Resume Next
    For i = 1 To UBound(tbl, 1)
        For j = 3 To 6
            If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j))
        Next j
    Next i
    On Error GoTo 0

    For i = 1 To Names.Count
        dest.Cells(i + 2, 1).Value = Names(i)
    Next i

    With dest.Range("A1:A2")
        .ClearFormats: .Merge: .Value = "الإســـم": .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter: .Font.Bold = True
        .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255)
        .Interior.color = RGB(200, 200, 255)
    End With

    For i = 1 To lastRow - 3
        For j = 1 To Names.Count
            If Not IsEmpty(dest.Cells(j + 2, 1)) Then
                name = Names(j)
                c = dest.Cells(1, i + 1).Value
                kay = ""

                For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row)
                    If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then
                        kay = (cell.Column - 9) & " مخزن"
                        Exit For
                    End If
                Next cell
                
                dest.Cells(j + 2, i + 1).Value = kay
                With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1))
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Borders(xlEdgeBottom).color = RGB(0, 0, 255)
                End With
            End If
        Next j
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub Colors(cell As Range, color As Long)
    With cell
        .Interior.color = color
        .Font.Bold = True
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
    End With
End Sub

 

New.xlsb