说明：因为本人有严重强迫症，每次创建透视表都要改下表名（相信有强迫症的小伙伴不少吧，嘿嘿），所以打算写一个自动创建透视表的宏，免得每次都要改下透视表的工作表名（懒癌晚期）。
代码思路：根据所选定单元格扩展（CTRL A），与鼠标操作基本一致，再创建名为“透视”的工作表，并在新表中创建透视表。如果已有名为“透视”的工作表，即重名就创建“透视1”，依次类推，透视 N。
3.0版新增透视表源数据缺标签会报错提醒，如果所选择的数据源有问题，会自动提示并用鼠标重新手选源范围。
BUG：如果数据源选不对，会一直报错下去，无限循环。另外会自动增加第一个单元格为标签列。
===============================
Sub 新建透视表()
Set abb = ActiveSheet
Set fanwei = Selection.CurrentRegion '扩展范围
'fanwei.Select
lastcell = fanwei.Count '找出单元格数量
Set ab = fanwei.Cells(1, 1) '找出第一个单元格
Set ac = fanwei.Cells(lastcell) '找出最后一个单元格
s = ab.Row '上边界
Z = ab.Column '左边界
x = ac.Row '右边界
y = ac.Column '下边界
fromadd = ActiveSheet.Name & "!R" & s & "C" & Z & ":R" & x & "C" & y '得出透视表的范围
arr = Application.Transpose([{"";1;2;3;4;5;6;7;8;9}])
Set abc = Sheets.Add
On Error Resume Next
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
fromadd, Version:=6).CreatePivotTable TableDestination:= _
abc.Name & "!R3C1", TableName:="数据透视表" & n, DefaultVersion:=6 '新建透视表,并命名透视表名为表n
With ActiveSheet.PivotTables("数据透视表").PivotFields(ab.Value)
.Orientation = xlRowField
.Position = 1
End With
[a3].Select
Do
n = n 1
abc.Name = "透视" & arr(n)
Loop Until Left(abc.Name, 2) = "透视"
If abc.[a3] = "" Then GoTo 100:
Exit Sub
100:
abb.Activate
Set fanwei = Application.InputBox("创建透视表失败，缺少首列标签，请重新选择区域", , , , , , , 8)
lastcell = fanwei.Count '找出单元格数量
Set ab = fanwei.Cells(1, 1) '找出第一个单元格
Set ac = fanwei.Cells(lastcell) '找出最后一个单元格
s = ab.Row '上边界
Z = ab.Column '左边界
x = ac.Row '右边界
y = ac.Column '下边界
abcnamne = abc.Name
fromadd = ActiveSheet.Name & "!R" & s & "C" & Z & ":R" & x & "C" & y '得出透视表的范围
'Application.DisplayAlerts = False
abc.Activate
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
fromadd, Version:=6).CreatePivotTable TableDestination:= _
abc.Name & "!R3C1", TableName:="数据透视表" & n, DefaultVersion:=6 '新建透视表,并命名透视表名为表n
With abc.PivotTables("数据透视表").PivotFields(ab.Value)
.Orientation = xlRowField
.Position = 1
End With
If abc.[a3] = "" Then GoTo 100:
arr = Application.Transpose([{"";1;2;3;4;5;6;7;8;9}])
Do
n = n 1
abc.Name = "透视" & arr(n)
Loop Until Left(abc.Name, 2) = "透视"
Application.DisplayAlerts = TURE
End Sub
