جابجایی های سه بعدی در اکسل

Question

به‌عنوان یک کاربر سنگین سابق Lotus 1-2-3 در کار قبلی، پتی بسیار به ویژگی‌ای که به شدت در اکسل فاقد آن است وصل شد: توانایی انتقال داده‌ها در سه بعدی. جابه‌جایی دو بعدی در اکسل پشتیبانی می‌شود، اما پتی راهی برای برداشتن یک ردیف یا ستون یا جدول و پخش آن در یک پشته از کاربرگ‌ها پیدا نکرده است. این عملکردی بود که هر روز توسط همه در دفتر مالی او استفاده می شد و او واقعاً دلتنگ آن است.

حق با پتی است. هیچ تابع داخلی برای انجام این کار در اکسل وجود ندارد. نزدیک‌ترین گزینه استفاده از PivotTable و قابلیت‌های «نمایش صفحات» است. به طور کلی، این مراحل را دنبال می کنید:

1. یک PivotTable از داده های خود همانطور که به طور معمول انجام می دهید ایجاد کنید.
2. ستونی را که می‌خواهید کاربرگ‌هایی از آن ایجاد شود، در بخش «فیلتر گزارش» از PivotTable قرار دهید.
3. تب Options روبان را نمایش دهید. (این برگه فقط زمانی قابل مشاهده است که روی یک PivotTable کار می کنید.)
4. روی فلش رو به پایین کنار ابزار Options در گروه PivotTable در انتهای سمت چپ نوار کلیک کنید.
5. نمایش صفحات فیلتر گزارش را انتخاب کنید. اکسل از شما می خواهد که تأیید کنید که می خواهید صفحات را نشان دهید.
6. 6 روی OK کلیک کنید.

چیزی که در نهایت به آن می رسید یک سری کاربرگ است، یکی برای هر ورودی در ستونی که در مرحله 2 مشخص کرده اید. این کاربرگ ها هر کدام حاوی یک "صفحه" از PivotTable هستند.

اگر هنوز هم آن چیزی را که می‌خواهید انجام نمی‌دهد، باید از یک ماکرو برای انتقال داده‌ها استفاده کنید. چنین ماکرویی می‌تواند بسیار پیچیده باشد، اما اساساً تنها کاری که باید انجام دهد این است که از جدول داده‌های شما عبور کرده و هر سطر (یا ستون) داده را به کاربرگ خود منتقل کند.

به عنوان مثال، ماکرو زیر (Transpose3D) هر ردیف را از یک محدوده انتخاب شده از سلول ها می گیرد و آن سطر را در کاربرگ تازه ایجاد شده خودش قرار می دهد.

Sub Transpose3D()
    Dim rngTbl As Range
    Dim wsName As String
    Dim R As Integer
    Dim C As Integer
    Dim i As Integer
    Dim j As Integer
    Dim Killit As Integer
    Dim RCount As Integer
    Dim CCount As Integer
    Dim Table1() As Variant
    Dim Row1() As Variant

    RCount = Selection.Rows.Count
    CCount = Selection.Columns.Count
    If RCount < 2 Then
        MsgBox ("Error; Select a range with more than one row.")
        GoTo EndItAll
    End If

    wsName = ActiveSheet.Name
    R = ActiveCell.Row
    C = ActiveCell.Column

    Set rngTbl = Selection
    ReDim Table1(1 To RCount, 1 To CCount)
    ReDim Row1(1 To 1, 1 To CCount)
    Table1() = rngTbl.Value

    On Error GoTo Abend

    For i = 1 To RCount
         If SheetExists(wsName & "_Row_" & i) Then
            Killit = MsgBox("Sheet " & wsName & "_Row_" & i & _
              " Already Exists!" & vbCrLf & _
              "     Cancel: Stop Transposition" & vbCrLf & _
              "     OK: Delete Sheet and Continue", vbOKCancel)
            If Killit = vbCancel Then GoTo EndItAll
            Application.DisplayAlerts = False
            Sheets(wsName & "_Row_" & i).Delete
            Application.DisplayAlerts = True
        End If

        Sheets.Add
        ActiveSheet.Name = wsName & "_Row_" & i
        Cells(R, C).Select
        For j = 1 To CCount
            Row1(1, j) = Table1(i, j)
        Next j
        Range(ActiveCell, ActiveCell.Offset(0, CCount - 1)) = Row1()
        Sheets(wsName).Select
    Next i
    GoTo EndItAll

Abend:
    MsgBox ("Error in Routine Transpose3D.")

EndItAll:
    Application.DisplayAlerts = True
End Sub

Function SheetExists(SheetName As String) As Boolean
    Dim ws As Worksheet
    SheetExists = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = SheetName Then
            SheetExists = True
            Exit For
        End If
    Next ws
End Function