Excel 数据透视表 - 使用日期和另一列格式化和分组列

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

我想安排数据透视表，使其看起来像这样：

Table Example with Correct Formatting

我几乎可以让它工作的唯一方法是它看起来像这样：

PivotTable Example - Not correct formatting

我真的需要格式和图片一完全一样。

感谢您提供的任何帮助。

excel 步骤或 VBA 代码中的答案会很棒 :)

Answer 1

我认为您无法通过数据透视表获得所需的准确输出。所以我写了一个代码，它首先创建一个尽可能接近的数据透视表。然后是其他宏，它将创建您在图片中放置的确切格式表。

1) 但是，您可以（可以很容易地自动化）替换您的行数据：

Start1

Middle2

End3

你的行数据标题应该在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