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

Question

I have worked with basic pivot tables for a few years, however I am getting stuck on something that I think should be fairly simple to solve (ugh).

I would like to format my pivot table in a specific way.

For example, just say I am using the following data:

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

I would like to arrange the pivot table so that it looks like this:

Table Example with Correct Formatting

The only way I can almost get it to work is if it looks like this:

PivotTable Example - Not correct formatting

I really need the formatting to be exactly like picture one.

Thanks for any help you may be able to provide.

Answers in excel steps or in VBA code would be awesome :)

Answer 1

I think you cannot have exactly the output that you want with a pivote table. So i wrote a code which create first a pivot table as close as you want. And then other macro which will create the exact format table as you put in the picture.

1) However you have (it could be easily automated) to replace in your row data:

Start by 1

Middle by 2

End by 3

And your row data tittles should be in Sheet1 and start cell A1

Main sub to call all codes: (all codes have to be in the same module. How hope it can help you.

Sub main()

Call PivotTable
Call FinalTable
Call DeleteRow
Call FormatTable

End Sub

Here is the first code that create the pivot table:

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

To format:

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

Code to delete the empty rows in your Final Table

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

Code to put border in your final table:

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

The subroutine to find the next client name:

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