Excel Pivot表-具有日期和另一列的格式設置和分組列

Question

我使用基本數據透視表已經有幾年了，但是我陷入了一些我認為應該很容易解決的問題。

我想以特定方式格式化我的數據透視表。

例如，僅說我正在使用以下數據：

Client Name Stage   Amount Paid  Date Paid
Client A    Start    $70,000     1/10/2015
Client A    Middle   $50,000     1/11/2015
Client A    End      $30,000     1/12/2015
Client B    Start    $50,000     5/11/2015
Client B    Middle   $30,000     5/11/2015
Client B    End      $50,000     5/12/2015
Client C    Start    $10,000     10/12/2015
Client C    Middle   $20,000     20/12/2015
Client C    End      $30,000     30/12/2015

我想安排數據透視表，使其看起來像這樣：

具有正確格式的表格示例

我幾乎可以正常使用的唯一方法是，它看起來像這樣：

數據透視表示例-格式不正確

我確實需要將其格式設置為與圖片一模一樣。

感謝您提供的任何幫助。

excel步驟或VBA代碼中的答案都很棒:)

Answer 1

我認為您無法通過數據透視表確切獲得所需的輸出。 所以我寫了一個代碼，該代碼首先根據需要創建一個數據透視表。 然后是另一個宏，它將在您放入圖片時創建確切的格式表。

1）但是，您可以（可以很容易地使其自動化）替換行數據：

Start 1 Start

Middle乘2

以3 End

並且您的行數據標題應位於Sheet1並開始於Sheet1格A1

用來調用所有代碼的主要子代碼：（所有代碼必須在同一模塊中。希望它能為您提供多大的希望。

Sub main()

Call PivotTable
Call FinalTable
Call DeleteRow
Call FormatTable

End Sub

這是創建數據透視表的第一個代碼：

Sub PivotTable()

Dim PTCache As PivotCache
Dim PT As PivotTable

'1.CREATE DATA STORAGE UNIT
Set PTCache = ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=Range("A1").CurrentRegion)

'2. ADD WORKSHEET
Worksheets.Add
ActiveSheet.Name = "PivotTable1"

'3.CREATE PIVOT TABLE N*1
Set PT = ActiveSheet.PivotTables.Add( _
PivotCache:=PTCache, _
TableDestination:=Range("A3"))

'4. ENUMERATE PREFERENCES FOR PIVOTE TABLE
With PT
    .PivotFields("Client Name").Orientation = xlRowField
    .PivotFields("Amount Paid").Orientation = xlRowField
    .RowAxisLayout xlTabularRow
End With

'MODIFYING DATA FIELD CALCULATION
With PT.PivotFields("Client Name")
      .Subtotals(1) = False
End With

With PT.PivotFields("Date Paid")
 .Orientation = xlColumnField
    .Caption = " Date Paid"
End With

With PT.PivotFields("Stage")
  .Orientation = xlDataField
    .Caption = " Stage"
    .NumberFormat = "[=1]""Start"";[>2]""End"";""Middle"""
End With

With PT.PivotFields("Amount Paid")
 .Orientation = xlDataField
   .Function = xlSum
    .Caption = " Amount Paid"
End With

Range("C4").Select
Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, _
        False, True, False, False)

PT.DisplayErrorString = False
PT.HasAutoFormat = False

PT.PivotSelect "", xlDataAndLabel, True
Selection.Copy
Worksheets.Add
ActiveSheet.Name = "FinalTable"
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats

Rows(1).Delete
Columns("B").Delete
Columns("I").Delete
Columns("H").Delete


End Sub

格式化：

Sub FinalTable()
Dim Nextcell As Double
Dim j As Integer

    Lastrow = Sheets("FinalTable").Range("A1").SpecialCells(xlCellTypeLastCell).Row

i = 3
Do Until i = Lastrow

    NextProcess i, Nextcell, Lastrow, j
        For c = 2 To 7

        If j = Lastrow Then Exit Do


    If IsEmpty(Cells(i, c)) Then

        For j = Nextcell - 1 To i Step -1

            If Not IsEmpty(Cells(j, c)) And Not IsEmpty(Cells(j - 1, c)) Then
                 Range(Cells(j, c), Cells(j - 1, c)).Copy Cells(i, c)
                 Range(Cells(j, c), Cells(j - 1, c)).ClearContents
                Exit For
            End If

            If Not IsEmpty(Cells(j, c)) Then
                 Cells(j, c).Copy Cells(i, c)
                 Cells(j, c).ClearContents
                Exit For
            End If

             If Not IsEmpty(Cells(j - 1, c)) Then
                 Cells(j - 1, c).Copy Cells(i, c)
                 Cells(j - 1, c).ClearContents
                Exit For
            End If

        Next j

    End If

    Next c

StepB = Nextcell - i
i = StepB + i

Loop

i = 2

Do

    If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
        Rows(i).Delete
        i = i - 1

    End If

Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row

i = 1 + i
Loop Until i = Lastrow


End Sub

代碼刪除最終表中的空行

Sub DeleteRow()

Dim Lastrow As Long
Dim i As Integer

Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row

i = 2

Do

    If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
        Rows(i).Delete
        i = i - 1

    End If

Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row

i = 1 + i
Loop Until i = Lastrow

End Sub

將邊框放在最終表中的代碼：

Sub FormatTable()

Dim Nextcell As Double
Dim j As Integer

Lastrow = Sheets("FinalTable").Range("G" & Rows.Count).End(xlUp).Row

For i = 2 To Lastrow

    If Not IsEmpty(Cells(i, 1)) Then

        If Not IsEmpty(Cells(i + 1, 1)) Then

                Range(Cells(i, 1), Cells(i, 7)).BorderAround

        ElseIf Not IsEmpty(Cells(i + 2, 1)) Then

                NextProcess i, Nextcell, Lastrow, j

                Range(Cells(i, 1), Cells(Nextcell - 1, 7)).BorderAround

        Else

        Range(Cells(i, 1), Cells(Lastrow, 7)).BorderAround

        End If
    End If
    Range(Cells(1, 2), Cells(Lastrow, 3)).BorderAround
    Range(Cells(1, 4), Cells(Lastrow, 5)).BorderAround
    Range(Cells(1, 6), Cells(Lastrow, 7)).BorderAround

Next i


End Sub

查找下一個客戶端名稱的子例程：

Sub NextProcess(ByVal i As Integer, ByRef Nextcell As Double, ByVal Lastrow As Long, ByRef j As Integer)

Dim Found As Boolean
'Dim j As Integer

Found = False
j = i + 1

Do Until Found = True Or Lastrow = j

        If Not IsEmpty(Range("A" & j).Value) Then

                Nextcell = Cells(j, 1).Row
                Found = True

        End If

j = j + 1
Loop

End Sub