为什么现在点击更新Dashboard的时候会报错：创建数据透视表时出错：不能设置类PivotField的Name属性，但是生成的Dashboard是没有问题的
' ===== 主记录过程 =====
Public Sub RecordHistory()
Dim wsSchedule As Worksheet
Dim wsHistory As Worksheet
Dim lastRowSchedule As Long
Dim lastRowHistory As Long
Dim partialDictModules As Object
Dim partialDictGroups As Object
Dim allDictModules As Object
Dim allDictGroups As Object
Dim cell As Range
Dim key As Variant
Dim updateDate As Date
Dim count As Integer
Dim existingDateRow As Long
Dim i As Long
Dim rowsToDelete As Collection
Dim scheduleUpdateDate As Date
Dim buttonExists As Boolean
Dim buttonPosition As Range
Dim status As String
Dim moduleName As String
Dim groupName As String
Dim shp As Shape
buttonExists = False
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsSchedule = ThisWorkbook.Sheets("schedule")
If Not WorksheetExists("HistoryStorage") Then
Set wsHistory = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
wsHistory.Name = "HistoryStorage"
wsHistory.Range("A1:E1").value = Array("记录日期", "名称", "数量", "类型", "状态类型")
wsHistory.Range("A1:E1").Font.Bold = True
wsHistory.Columns("A").NumberFormat = "yyyy-mm-dd"
wsHistory.Columns("C").NumberFormat = "0"
Else
Set wsHistory = ThisWorkbook.Sheets("HistoryStorage")
' 检查按钮是否存在并记录位置
On Error Resume Next
Set buttonPosition = Nothing
For Each shp In wsHistory.Shapes
If shp.Type = msoFormControl And shp.FormControlType = xlButtonControl Then
Set buttonPosition = shp.TopLeftCell
buttonExists = True
Exit For
End If
Next shp
On Error GoTo 0
End If
scheduleUpdateDate = GetScheduleUpdateDate(wsSchedule)
If scheduleUpdateDate = 0 Then
updateDate = Date
MsgBox "无法从schedule表获取有效日期", vbExclamation
Else
updateDate = DateValue(scheduleUpdateDate)
End If
' 创建字典存储部分状态数据
Set partialDictModules = CreateObject("Scripting.Dictionary")
Set partialDictGroups = CreateObject("Scripting.Dictionary")
' 创建字典存储全部状态数据
Set allDictModules = CreateObject("Scripting.Dictionary")
Set allDictGroups = CreateObject("Scripting.Dictionary")
lastRowSchedule = wsSchedule.Cells(wsSchedule.rows.count, "D").End(xlUp).row
' 收集数据
For Each cell In wsSchedule.Range("D2:D" & lastRowSchedule)
status = Trim(UCase(wsSchedule.Cells(cell.row, "G").value))
moduleName = cell.value
groupName = Trim(wsSchedule.Cells(cell.row, "J").value)
' 收集全部状态数据
If moduleName <> "" Then
' 模块统计
allDictModules(moduleName) = allDictModules(moduleName) + 1
' 责任组统计
If groupName <> "" Then
allDictGroups(groupName) = allDictGroups(groupName) + 1
End If
End If
' 收集部分状态数据
If moduleName <> "" And _
(status = "ASSIGNED" Or _
status = "OPEN" Or _
status = "NEW") Then
' 模块统计
partialDictModules(moduleName) = partialDictModules(moduleName) + 1
' 责任组统计
If groupName <> "" Then
partialDictGroups(groupName) = partialDictGroups(groupName) + 1
End If
End If
Next cell
lastRowHistory = wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row
If wsHistory.Range("A1").value = "" Or wsHistory.Range("A1").value <> "记录日期" Then
wsHistory.Range("A1:E1").value = Array("记录日期", "名称", "数量", "类型", "状态类型")
wsHistory.Range("A1:E1").Font.Bold = True
wsHistory.Columns("A").NumberFormat = "yyyy-mm-dd"
wsHistory.Columns("C").NumberFormat = "0"
End If
Set rowsToDelete = New Collection
If lastRowHistory > 1 Then
For i = 2 To lastRowHistory
' 跳过按钮所在行
If buttonExists Then
If i = buttonPosition.row Then GoTo SkipRow
End If
If IsDate(wsHistory.Cells(i, "A").value) Then
If DateValue(wsHistory.Cells(i, "A").value) = updateDate Then
rowsToDelete.Add i
End If
End If
SkipRow:
Next i
End If
If rowsToDelete.count > 0 Then
For i = rowsToDelete.count To 1 Step -1
wsHistory.rows(rowsToDelete(i)).Delete
Next i
lastRowHistory = wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row
End If
If lastRowHistory = 1 Then
lastRowHistory = 2
Else
lastRowHistory = lastRowHistory + 1
End If
' 写入部分状态数据
WriteHistoryData wsHistory, lastRowHistory, updateDate, partialDictModules, "模块", "未解决状态"
lastRowHistory = wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row + 1
WriteHistoryData wsHistory, lastRowHistory, updateDate, partialDictGroups, "责任组", "未解决状态"
lastRowHistory = wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row + 1
' 写入全部状态数据
WriteHistoryData wsHistory, lastRowHistory, updateDate, allDictModules, "模块", "全部状态"
lastRowHistory = wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row + 1
WriteHistoryData wsHistory, lastRowHistory, updateDate, allDictGroups, "责任组", "全部状态"
' 调整列表对象范围到E列
On Error Resume Next
If wsHistory.ListObjects.count = 0 Then
wsHistory.Range("A1:E" & wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row).Select
wsHistory.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "HistoryStorage"
Else
wsHistory.ListObjects("HistoryStorage").Resize wsHistory.Range("A1:E" & wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row)
End If
On Error GoTo 0
wsHistory.Columns("A:E").AutoFit
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "运行时错误：" & Err.Description, vbCritical
End Sub
' ===== 新增辅助函数：写入历史数据 =====
Private Sub WriteHistoryData(ws As Worksheet, startRow As Long, recordDate As Date, dict As Object, dataType As String, statusType As String)
Dim key As Variant
For Each key In dict.keys
ws.Cells(startRow, "A").value = recordDate
ws.Cells(startRow, "B").value = key
ws.Cells(startRow, "C").value = dict(key)
ws.Cells(startRow, "D").value = dataType
ws.Cells(startRow, "E").value = statusType ' 状态类型列
startRow = startRow + 1
Next key
End Sub
' ===== 仪表板创建过程 =====
Public Sub CreateEnhancedHistoryChart()
Dim wsHistory As Worksheet
Dim wsDashboard As Worksheet
Dim pivotTableCache As PivotCache
Dim pivotTable As pivotTable
Dim lastRow As Long
Dim pivotRange As Range
Dim chartType As Integer
Dim dataField As String
Dim chartTitle As String
Dim pivotCreated As Boolean
' 字段名称变量
Dim dateFieldName As String
Dim itemFieldName As String
Dim countFieldName As String
Dim typeFieldName As String
Dim statusFieldName As String
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
' 检查HistoryStorage表是否存在
If Not WorksheetExists("HistoryStorage") Then
MsgBox "HistoryStorage表不存在，请先运行记录历史功能", vbExclamation
Exit Sub
End If
' === 添加状态类型选择 ===
Dim statusType As Integer
statusType = Application.InputBox("请选择要显示的状态类型:" & vbCrLf & _
"1 - 未解决状态 (ASSIGNED/OPEN/NEW)" & vbCrLf & _
"2 - 全部状态" & vbCrLf & _
"3 - 同时显示两种状态", _
"状态类型选择", 1, Type:=1)
' 验证用户选择
If statusType = 0 Then
MsgBox "操作已取消", vbInformation
Exit Sub
ElseIf statusType < 1 Or statusType > 3 Then
MsgBox "无效的选择，请输入1、2或3", vbExclamation
Exit Sub
End If
' === 添加图表类型选择 ===
chartType = Application.InputBox("请选择要显示的图表类型:" & vbCrLf & _
"1 - 模块名称" & vbCrLf & _
"2 - 责任组" & vbCrLf & _
"3 - 全部数据", _
"图表类型选择", 1, Type:=1)
' 验证用户选择
If chartType = 0 Then
MsgBox "操作已取消", vbInformation
Exit Sub
ElseIf chartType < 1 Or chartType > 3 Then
MsgBox "无效的选择，请输入1、2或3", vbExclamation
Exit Sub
End If
' 根据用户选择设置参数
Select Case chartType
Case 1 ' 仅模块
dataField = "模块"
chartTitle = "模块数量历史趋势"
Case 2 ' 仅责任组
dataField = "责任组"
chartTitle = "责任组数量历史趋势"
Case 3 ' 全部
dataField = ""
chartTitle = "综合数据历史趋势"
End Select
' 添加状态类型到标题
Select Case statusType
Case 1: chartTitle = chartTitle & " (未解决状态)"
Case 2: chartTitle = chartTitle & " (全部状态)"
Case 3: chartTitle = chartTitle & " (全部状态类型)"
End Select
Set wsHistory = ThisWorkbook.Sheets("HistoryStorage")
' 获取字段名称
dateFieldName = GetValidFieldName(wsHistory, "A")
itemFieldName = GetValidFieldName(wsHistory, "B")
countFieldName = GetValidFieldName(wsHistory, "C")
typeFieldName = GetValidFieldName(wsHistory, "D")
statusFieldName = GetValidFieldName(wsHistory, "E") ' 状态类型字段
' 检查是否有足够数据
lastRow = wsHistory.Cells(wsHistory.rows.count, "A").End(xlUp).row
If lastRow <= 1 Then
MsgBox "历史数据表为空，请先记录数据", vbExclamation
Exit Sub
End If
' 创建/重置仪表板工作表
If WorksheetExists("Dashboard") Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Dashboard").Delete
Application.DisplayAlerts = True
End If
Set wsDashboard = ThisWorkbook.Sheets.Add(After:=wsHistory)
wsDashboard.Name = "Dashboard"
' === 设置简洁仪表板布局 ===
With wsDashboard
.Range("A1").value = chartTitle
.Range("A1").Font.Bold = True
.Range("A1").Font.size = 20
.Range("A1").RowHeight = 35
.Columns("A:A").ColumnWidth = 20
.Columns("B:B").ColumnWidth = 35
.Columns("C:C").ColumnWidth = 15
End With
' 准备数据透视表范围
Set pivotRange = wsHistory.Range("A1:E" & lastRow)
' === 创建数据透视表 ===
CreatePivotTableWithAlternativeMethod wsDashboard, pivotRange, dateFieldName, _
itemFieldName, countFieldName, typeFieldName, dataField, chartType, _
chartTitle, statusFieldName, statusType
' 调整工作表视图
wsDashboard.Activate
wsDashboard.Range("A1").Select
CleanExit:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Dim errMsg As String
errMsg = "创建图表时出错: " & Err.Description & vbCrLf & _
"错误号: " & Err.Number & vbCrLf & _
"发生位置: " & Erl
MsgBox errMsg, vbCritical
End Sub
' ===== 修复后的透视表创建方法（保留列总计问题）=====
Private Sub CreatePivotTableWithAlternativeMethod(wsDashboard As Worksheet, _
pivotRange As Range, _
dateFieldName As String, _
itemFieldName As String, _
countFieldName As String, _
typeFieldName As String, _
dataField As String, _
chartType As Integer, _
chartTitle As String, _
statusFieldName As String, _
statusType As Integer)
On Error GoTo ErrorHandler
' 创建透视缓存
Dim pc As PivotCache
Set pc = ThisWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=pivotRange.Address(External:=True))
' 创建数据透视表
Dim pt As pivotTable
Set pt = pc.CreatePivotTable( _
TableDestination:=wsDashboard.Range("A3"), _
TableName:="SafePivot")
Application.ScreenUpdating = False
' === 添加字段（关键修复）===
' 1. 添加行字段（日期）
With pt.PivotFields(dateFieldName)
.orientation = xlRowField
.position = 1
End With
' 2. 添加列字段（项目）
With pt.PivotFields(itemFieldName)
.orientation = xlColumnField
.position = 1
End With
' 3. 添加数据字段（数量）
With pt.PivotFields(countFieldName)
.orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
.Name = "数量"
End With
' 4. 添加筛选字段（状态类型）
If statusType <> 3 Then ' 当选择3时显示全部状态
With pt.PivotFields(statusFieldName)
.orientation = xlPageField
.position = 1
' 设置筛选值
If statusType = 1 Then
.CurrentPage = "未解决状态"
ElseIf statusType = 2 Then
.CurrentPage = "全部状态"
End If
End With
End If
' 5. 添加额外筛选字段（数据类型）- 当用户选择特定类型时
If dataField <> "" Then
With pt.PivotFields(typeFieldName)
.orientation = xlPageField
.position = 1
.CurrentPage = dataField
End With
End If
' === 解决数据为空问题 ===
' 强制刷新透视表
pt.RefreshTable
DoEvents
' 检查是否有数据
If pt.DataBodyRange Is Nothing Then
MsgBox "数据透视表创建成功，但未找到匹配数据。请检查筛选条件。", vbExclamation
End If
' 调用简化版图表函数（避免复杂操作）
CreateSimpleChart wsDashboard, pt, chartTitle
Exit Sub
ErrorHandler:
MsgBox "创建数据透视表时出错: " & Err.Description, vbCritical
Resume Next
End Sub
' ===== 简化版图表创建 ====
Private Sub CreateSimpleChart(ws As Worksheet, pt As pivotTable, chartTitle As String)
On Error Resume Next
' 确定图表位置
Dim chartTop As Long
chartTop = pt.TableRange2.row + pt.TableRange2.rows.count + 2
' 创建图表对象
Dim chtObj As ChartObject
Set chtObj = ws.ChartObjects.Add( _
Left:=50, _
Top:=chartTop, _
Width:=600, _
Height:=400)
Dim cht As Chart
Set cht = chtObj.Chart
' 设置图表类型和标题
cht.chartType = xlLine
cht.HasTitle = True
cht.chartTitle.Text = chartTitle
' === 手动添加系列 ===
Dim srs As Series
Dim col As Long
' 添加每个数据系列
For col = 1 To pt.DataBodyRange.Columns.count
Set srs = cht.SeriesCollection.NewSeries
With srs
.Name = pt.ColumnRange.Cells(1, col).value
.values = pt.DataBodyRange.Columns(col)
.XValues = pt.RowRange.Offset(1).Resize(pt.DataBodyRange.rows.count)
End With
Next col
' 添加总计系列
Set srs = cht.SeriesCollection.NewSeries
With srs
.Name = "总计"
.values = GetManualRowTotals(pt)
.XValues = pt.RowRange.Offset(1).Resize(pt.DataBodyRange.rows.count)
.Border.Color = RGB(0, 0, 255)
.MarkerStyle = xlMarkerStyleSquare
End With
End Sub
' ===== 手动计算行总计 ====
Private Function GetManualRowTotals(pt As pivotTable) As Variant
Dim dataRange As Range
Dim totalValues() As Double
Dim i As Long, j As Long
Set dataRange = pt.DataBodyRange
If dataRange Is Nothing Then
ReDim totalValues(1 To 1)
totalValues(1) = 0
GetManualRowTotals = totalValues
Exit Function
End If
ReDim totalValues(1 To dataRange.rows.count)
For i = 1 To dataRange.rows.count
Dim rowTotal As Double
rowTotal = 0
For j = 1 To dataRange.Columns.count
If IsNumeric(dataRange.Cells(i, j).value) Then
rowTotal = rowTotal + dataRange.Cells(i, j).value
End If
Next j
totalValues(i) = rowTotal
Next i
GetManualRowTotals = totalValues
End Function
' === 新增：通过XML操作仅禁用列总计 ===
Private Sub ForceDisablePivotColumnTotalOnly(pt As pivotTable)
On Error Resume Next
Dim xmlDoc As Object
Dim xmlNode As Object
' 获取透视表XML
Dim xml As String
xml = pt.PivotTableXML
' 创建XML文档对象
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.LoadXML xml
' 禁用列总计（showColGrandTotals设为0），保留行总计（showRowGrandTotals设为1）
Set xmlNode = xmlDoc.SelectSingleNode("//pivotTableDefinition/showRowGrandTotals")
If Not xmlNode Is Nothing Then xmlNode.Text = "1" ' 保留行总计
Set xmlNode = xmlDoc.SelectSingleNode("//pivotTableDefinition/showColGrandTotals")
If Not xmlNode Is Nothing Then xmlNode.Text = "0" ' 禁用列总计
' 应用修改后的XML
pt.PivotTableXML = xmlDoc.xml
' 刷新透视表
pt.RefreshTable
End Sub
' ===== 完全重写的图表创建函数 =====
Public Sub CreateEnhancedLineChart(ws As Worksheet, pt As pivotTable, chartTitle As String)
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
' 1. 强制刷新透视表
pt.ManualUpdate = False
pt.RefreshTable
DoEvents
' 2. 验证透视表数据范围
If pt.TableRange2 Is Nothing Or pt.TableRange2.rows.count < 2 Then
MsgBox "数据透视表没有足够的数据创建图表", vbExclamation
GoTo CleanExit
End If
' 3. 创建图表对象（绝对位置）
Dim chtObj As ChartObject
Set chtObj = ws.ChartObjects.Add(Left:=50, Top:=100, Width:=600, Height:=400)
Dim cht As Chart
Set cht = chtObj.Chart
' 4. 设置图表基本属性（避免使用SetSourceData）
cht.chartType = xlLineMarkers
cht.HasTitle = True
cht.chartTitle.Text = chartTitle
' === 关键修改1：手动添加数据系列 ===
Dim srs As Series
Dim col As Long
Dim lastRow As Long
lastRow = pt.DataBodyRange.rows.count
' 添加每个数据系列
For col = 1 To pt.DataBodyRange.Columns.count - 1 ' 排除总计列
Set srs = cht.SeriesCollection.NewSeries
With srs
.Name = pt.TableRange2.Cells(1, col + 1).value
.values = pt.DataBodyRange.Columns(col)
.XValues = pt.RowRange.Offset(1).Resize(lastRow)
End With
Next col
' === 关键修改2：安全添加行总计系列 ===
Dim totalValues As Variant
totalValues = GetSafeRowTotalValues(pt, lastRow)
If Not IsEmpty(totalValues) Then
Set srs = cht.SeriesCollection.NewSeries
With srs
.Name = "行总计"
.values = totalValues
.XValues = pt.RowRange.Offset(1).Resize(lastRow)
.Border.Color = RGB(0, 0, 255)
.MarkerStyle = xlMarkerStyleSquare
.MarkerSize = 7
End With
Else
MsgBox "无法获取行总计数据", vbExclamation
End If
' 5. 设置图表格式
With cht
.HasLegend = True
.Legend.position = xlLegendPositionBottom
With .Axes(xlCategory)
.CategoryType = xlCategoryScale
.TickLabels.orientation = xlHorizontal
End With
With .Axes(xlValue)
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(200, 200, 200)
End With
End With
CleanExit:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrorHandler:
' 详细错误处理
Dim errMsg As String
errMsg = "图表创建错误[" & Err.Number & "]: " & Err.Description & vbCrLf & _
"错误发生在：" & GetErrorLocation(Erl)
' 尝试基础图表作为后备方案
On Error Resume Next
CreateBasicLineChart ws, pt.DataBodyRange, chartTitle
On Error GoTo 0
MsgBox errMsg, vbCritical
Resume CleanExit
End Sub
' ===== 安全获取行总计值（带维度验证） =====
Private Function GetSafeRowTotalValues(pt As pivotTable, expectedSize As Long) As Variant
On Error Resume Next
Dim values() As Double
Dim rowTotalRange As Range
Dim i As Long
' 方法1：尝试获取总计列
Dim rowTotalCol As Long
rowTotalCol = FindTotalColumn(pt, False) ' 查找行总计列
If rowTotalCol > 0 Then
Set rowTotalRange = pt.DataBodyRange.Resize(, 1).Offset(, rowTotalCol - 1)
' 验证维度
If rowTotalRange.rows.count = expectedSize Then
ReDim values(1 To expectedSize)
For i = 1 To expectedSize
values(i) = Val(rowTotalRange.Cells(i, 1).value)
Next i
GetSafeRowTotalValues = values
Exit Function
End If
End If
' 方法2：手动计算总计
GetSafeRowTotalValues = CalculateManualRowTotal(pt, expectedSize)
End Function
' ===== 维度安全的行总计计算 =====
Private Function CalculateManualRowTotal(pt As pivotTable, expectedSize As Long) As Variant
Dim dataRange As Range
Dim values() As Double
Dim i As Long, j As Long
Set dataRange = pt.DataBodyRange
If dataRange Is Nothing Then
ReDim values(1 To expectedSize)
CalculateManualRowTotal = values
Exit Function
End If
ReDim values(1 To expectedSize)
For i = 1 To expectedSize
Dim rowTotal As Double
rowTotal = 0
' 排除最后一列（总计列）
For j = 1 To dataRange.Columns.count - 1
If IsNumeric(dataRange.Cells(i, j).value) Then
rowTotal = rowTotal + dataRange.Cells(i, j).value
End If
Next j
values(i) = rowTotal
Next i
CalculateManualRowTotal = values
End Function
' ===== 错误定位辅助函数 =====
Private Function GetErrorLocation(lineNum As Long) As String
Select Case lineNum
Case 0: GetErrorLocation = "图表对象创建"
Case 1: GetErrorLocation = "透视表刷新"
Case 2: GetErrorLocation = "数据范围验证"
Case 3: GetErrorLocation = "添加数据系列"
Case 4: GetErrorLocation = "添加总计系列"
Case 5: GetErrorLocation = "图表格式设置"
Case Else: GetErrorLocation = "未知位置"
End Select
End Function
' ===== 获取分类轴标签 =====
Private Function GetCategoryLabels(pt As pivotTable) As Variant
On Error Resume Next
Dim labelRange As Range
' 尝试获取行字段标签
If Not pt.RowRange Is Nothing Then
Set labelRange = pt.RowRange.Offset(1).Resize(pt.RowRange.rows.count - 1)
End If
' 后备方案：使用日期列
If labelRange Is Nothing Then
Set labelRange = pt.DataBodyRange.Columns(1)
End If
Set GetCategoryLabels = labelRange
End Function
' ===== 增强版获取行总计值函数 =====
Private Function GetRowTotalValues(pt As pivotTable) As Variant
On Error Resume Next
Dim rowTotalRange As Range
Dim values() As Double
Dim i As Long
' 1. 查找行总计列
Dim rowTotalCol As Long
rowTotalCol = FindTotalColumn(pt, False) ' False表示查找行总计
' 2. 如果找到总计列
If rowTotalCol > 0 Then
Set rowTotalRange = pt.DataBodyRange.Resize(, 1).Offset(, rowTotalCol - 1)
' 3. 验证数据范围
If Not rowTotalRange Is Nothing And rowTotalRange.rows.count > 0 Then
ReDim values(1 To rowTotalRange.rows.count)
' 4. 填充值数组
For i = 1 To rowTotalRange.rows.count
If IsNumeric(rowTotalRange.Cells(i, 1).value) Then
values(i) = rowTotalRange.Cells(i, 1).value
Else
values(i) = 0
End If
Next i
GetRowTotalValues = values
Exit Function
End If
End If
' 5. 后备方案：手工计算行总计
GetRowTotalValues = CalculateManualRowTotal(pt)
End Function
' ===== 增强版查找总计列函数 =====
Private Function FindTotalColumn(pt As pivotTable, ByVal findColumnTotal As Boolean) As Long
On Error Resume Next
Dim rng As Range
Dim headerCell As Range
Dim searchTerms As Variant
Dim i As Long
' 设置搜索术语（多语言支持）
If findColumnTotal Then
searchTerms = Array("列总计", "Column Total", "Grand Total")
Else
searchTerms = Array("行总计", "Row Total", "Grand Total")
End If
' 获取标题行范围（通常是第一行或第二行）
If pt.RowRange.rows.count > 1 Then
Set rng = pt.RowRange.rows(1)
Else
Set rng = pt.TableRange2.rows(1)
End If
' 遍历标题行查找匹配项
For i = 1 To rng.Columns.count
Set headerCell = rng.Cells(1, i)
' 检查是否匹配任何搜索术语
For Each term In searchTerms
If InStr(1, headerCell.value, term, vbTextCompare) > 0 Then
FindTotalColumn = i
Exit Function
End If
Next term
Next i
' 如果找不到，返回0
FindTotalColumn = 0
End Function
' === 手动计算行总计值 ===
Private Function GetManualRowTotalValues(pt As pivotTable) As Variant
Dim i As Long, j As Long
Dim dataRange As Range
Dim values() As Double
Dim columnCount As Long
Set dataRange = pt.DataBodyRange
If dataRange Is Nothing Then
ReDim values(1 To 1)
values(1) = 0
GetManualRowTotalValues = values
Exit Function
End If
columnCount = dataRange.Columns.count
ReDim values(1 To dataRange.rows.count)
' 手动计算每行的总和（排除列总计列）
For i = 1 To dataRange.rows.count
Dim rowTotal As Double
rowTotal = 0
' 排除最后一列（列总计）
For j = 1 To columnCount - 1
If IsNumeric(dataRange.Cells(i, j).value) Then
rowTotal = rowTotal + dataRange.Cells(i, j).value
End If
Next j
values(i) = rowTotal
Next i
GetManualRowTotalValues = values
End Function
' === 终极方法：通过XML操作强制禁用总计 ===
Private Sub ForceDisablePivotTotal(pt As pivotTable)
On Error Resume Next
Dim xmlDoc As Object
Dim xmlNode As Object
' 获取透视表XML
Dim xml As String
xml = pt.PivotTableXML
' 创建XML文档对象
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.LoadXML xml
' 查找总计设置节点
Set xmlNode = xmlDoc.SelectSingleNode("//pivotTableDefinition/showRowGrandTotals")
If Not xmlNode Is Nothing Then xmlNode.Text = "0"
Set xmlNode = xmlDoc.SelectSingleNode("//pivotTableDefinition/showColGrandTotals")
If Not xmlNode Is Nothing Then xmlNode.Text = "0"
' 应用修改后的XML
pt.PivotTableXML = xmlDoc.xml
' 刷新透视表
pt.RefreshTable
End Sub
' ===== 后期绑定创建数据透视表 =====
Private Sub CreatePivotUsingLateBinding(wsDashboard As Worksheet, _
pivotRange As Range, _
dateFieldName As String, _
itemFieldName As String, _
countFieldName As String, _
typeFieldName As String, _
dataField As String, _
chartType As Integer, _
chartTitle As String, _
statusFieldName As String, _
statusType As Integer)
On Error GoTo ErrorHandler
Dim wb As Object, ws As Object, pc As Object, pt As Object, pf As Object
Set wb = ThisWorkbook
Set ws = wsDashboard
' 创建PivotCache
Set pc = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=pivotRange)
' 创建PivotTable
Set pt = pc.CreatePivotTable(TableDestination:=ws.Range("A3"), TableName:="LateBoundPivot")
' 添加行字段（日期）
Set pf = pt.PivotFields(dateFieldName)
pf.orientation = 1 ' xlRowField
pf.position = 1
' 添加列字段（项目）
Set pf = pt.PivotFields(itemFieldName)
pf.orientation = 2 ' xlColumnField
pf.position = 1
' === 添加状态类型过滤 ===
If statusType = 1 Or statusType = 2 Then
Set pf = pt.PivotFields(statusFieldName)
pf.orientation = 3 ' xlPageField
pf.position = 1
If statusType = 1 Then
pf.CurrentPage = "未解决状态"
ElseIf statusType = 2 Then
pf.CurrentPage = "全部状态"
End If
End If
' 添加过滤字段（如果需要）
If dataField <> "" Then
Set pf = pt.PivotFields(typeFieldName)
pf.orientation = 3 ' xlPageField
pf.position = 1
pf.CurrentPage = dataField
End If
' 添加数据字段
Set pf = pt.PivotFields(countFieldName)
pf.orientation = 4 ' xlDataField
pf.Function = -4157 ' xlSum
pf.NumberFormat = "#,##0"
pf.Name = "数量"
' 添加额外的行字段（如果需要）
If chartType <> 3 Then
Set pf = pt.PivotFields(typeFieldName)
pf.orientation = 1 ' xlRowField
pf.position = 2
End If
' 【关键修改】禁用所有总计
pt.RowGrand = False
pt.ColumnGrand = False ' 禁用列总计
' === 防止自动格式重置设置 ===
pt.HasAutoFormat = False
' 再次确认禁用列总计
pt.ColumnGrand = False
pt.RefreshTable
' 调用增强版图表函数
CreateEnhancedLineChart wsDashboard, pt, chartTitle
Exit Sub
ErrorHandler:
' 后备方案：基于原始数据创建简单折线图
CreateBasicLineChart wsDashboard, pivotRange, chartTitle
End Sub
' === 新的手动计算总计函数 ===
Private Function GetManualTotalValues(pt As pivotTable) As Variant
Dim i As Long, j As Long
Dim dataRange As Range
Dim values() As Double
Set dataRange = pt.DataBodyRange
If dataRange Is Nothing Then
ReDim values(1 To 1)
values(1) = 0
GetManualTotalValues = values
Exit Function
End If
ReDim values(1 To dataRange.rows.count)
' 手动计算每行的总和
For i = 1 To dataRange.rows.count
Dim rowTotal As Double
rowTotal = 0
For j = 1 To dataRange.Columns.count
If IsNumeric(dataRange.Cells(i, j).value) Then
rowTotal = rowTotal + dataRange.Cells(i, j).value
End If
Next j
values(i) = rowTotal
Next i
GetManualTotalValues = values
End Function
' === 辅助函数：获取总计值数组 ===
Private Function GetTotalValues(pt As pivotTable) As Variant
Dim i As Long
Dim values() As Double
Dim dataRange As Range
Dim totalCol As Long
' 查找总计列的位置
totalCol = 0
For i = 1 To pt.ColumnFields.count
If InStr(1, pt.ColumnFields(i).Name, "总计") > 0 Or _
InStr(1, pt.ColumnFields(i).Name, "Grand Total") > 0 Then
totalCol = i
Exit For
End If
Next i
' 获取总计列数据
If totalCol > 0 Then
Set dataRange = pt.DataBodyRange.Offset(0, totalCol - 1).Resize(pt.DataBodyRange.rows.count, 1)
ReDim values(1 To dataRange.rows.count)
For i = 1 To dataRange.rows.count
values(i) = dataRange.Cells(i, 1).value
Next i
GetTotalValues = values
Else
' 计算总计值
Dim j As Long
Set dataRange = pt.DataBodyRange
ReDim values(1 To dataRange.rows.count)
For i = 1 To dataRange.rows.count
Dim rowTotal As Double
rowTotal = 0
For j = 1 To dataRange.Columns.count
rowTotal = rowTotal + dataRange.Cells(i, j).value
Next j
values(i) = rowTotal
Next i
GetTotalValues = values
End If
End Function
' ===== 基础折线图后备方案 =====
Private Sub CreateBasicLineChart(ws As Worksheet, dataRange As Range, chartTitle As String)
On Error Resume Next
' 创建图表对象
Dim chartObj As ChartObject
Set chartObj = ws.ChartObjects.Add( _
Left:=100, _
Top:=100, _
Width:=600, _
Height:=400)
' 配置基础折线图
With chartObj.Chart
.SetSourceData Source:=dataRange
.chartType = xlLine
.HasTitle = True
.chartTitle.Text = chartTitle & " (基础图表)"
.HasLegend = True
.Legend.position = xlBottom
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Text = "数量"
End With
End Sub
Function GetScheduleUpdateDate(wsSchedule As Worksheet) As Date
Dim lastRow As Long
Dim i As Long
Dim cellValue As Variant
Dim potentialDate As Date
Dim maxDate As Date
Dim found As Boolean
On Error GoTo ErrorHandler
lastRow = wsSchedule.Cells(wsSchedule.rows.count, "I").End(xlUp).row
found = False
maxDate = 0
For i = 2 To lastRow
cellValue = wsSchedule.Cells(i, "I").value
If cellValue <> "" Then
If IsDate(cellValue) Then
potentialDate = CDate(cellValue)
If Year(potentialDate) > 1900 Then
' 关键修改：只比较日期部分
If DateValue(potentialDate) > maxDate Or Not found Then
maxDate = DateValue(potentialDate)
found = True
End If
End If
End If
End If
Next i
If found Then
' 关键修改：返回纯日期（无时间部分）
GetScheduleUpdateDate = maxDate
Else
GetScheduleUpdateDate = 0
End If
Exit Function
ErrorHandler:
GetScheduleUpdateDate = 0
End Function
' ===== 新增按钮创建函数 =====
Sub CreateRecordButton()
Dim ws As Worksheet
Dim btn As Button
' 确保HistoryStorage表存在
If Not WorksheetExists("HistoryStorage") Then
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
ws.Name = "HistoryStorage"
Else
Set ws = ThisWorkbook.Sheets("HistoryStorage")
End If
' 删除现有按钮（如果有）
On Error Resume Next
For Each shp In ws.Shapes
If shp.Type = msoFormControl And shp.FormControlType = xlButtonControl Then
shp.Delete
End If
Next shp
On Error GoTo 0
' 创建新按钮
Set btn = ws.buttons.Add(10, 10, 120, 30) ' 位置和大小
With btn
.Caption = "记录历史"
.OnAction = "RecordHistory"
.Name = "RecordHistoryButton"
End With
' 设置按钮位置（固定位置）
ws.Range("E1").value = "按钮位置标记"
btn.Top = ws.Range("E1").Top
btn.Left = ws.Range("E1").Left
End Sub
' ===== 修改Workbook_Open事件 =====
Private Sub Workbook_Open()
' 打开工作簿时创建按钮
CreateRecordButton
End Sub
' ===== 检查工作表是否存在 =====
Private Function WorksheetExists(sheetName As String) As Boolean
On Error Resume Next
WorksheetExists = Not ThisWorkbook.Sheets(sheetName) Is Nothing
On Error GoTo 0
End Function
Function GetValidFieldName(ws As Worksheet, col As String) As String
On Error Resume Next
GetValidFieldName = Trim(ws.Range(col & "1").value)
If GetValidFieldName = "" Or Err.Number <> 0 Then
Select Case col
Case "A": GetValidFieldName = "记录日期"
Case "B": GetValidFieldName = "名称"
Case "C": GetValidFieldName = "数量"
Case "D": GetValidFieldName = "类型"
Case "E": GetValidFieldName = "状态类型"
End Select
End If
End Function
最新发布
xlwings API提供了Range.PivotField属性，用于获取Range对象左上角数据透视表字段的对象。通过这个属性，可以方便地对数据透视表字段进行操作和获取其详细信息。
扫一扫
160
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
