图中还是没有行总计的数据，顺便帮我把没有用的函数删除了
' ===== 主记录过程 =====
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
' === 添加字段 ===
With pt.PivotFields(dateFieldName)
.orientation = xlRowField
.position = 1
End With
With pt.PivotFields(itemFieldName)
.orientation = xlColumnField
.position = 1
End With
With pt.PivotFields(countFieldName)
.orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
End With
' === 添加字段 ===
If statusType <> 3 Then
With pt.PivotFields(statusFieldName)
.orientation = xlPageField
.position = 1
If statusType = 1 Then
.CurrentPage = "未解决状态"
ElseIf statusType = 2 Then
.CurrentPage = "全部状态"
End If
End With
End If
If dataField <> "" Then
With pt.PivotFields(typeFieldName)
.orientation = xlPageField
.position = 1
.CurrentPage = dataField
End With
End If
' === 关键修改：禁用列总计 ===
pt.ColumnGrand = False ' 禁用列总计
pt.RowGrand = True ' 保留行总计（可选）
' 强制刷新透视表
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 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.ColumnGrand = False ' 禁用列总计
pt.RowGrand = True ' 保留行总计（可选）
' 调用图表函数
CreateSimpleChart wsDashboard, pt, chartTitle
Exit Sub
ErrorHandler:
CreateBasicLineChart wsDashboard, pivotRange, chartTitle
End Sub
' ===== 修复后的图表创建函数 =====
Private Sub CreateSimpleChart(ws As Worksheet, pt As pivotTable, chartTitle As String)
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
' 检查传入的参数有效性
If pt Is Nothing Then
MsgBox "数据透视表对象无效", vbExclamation
Exit Sub
End If
' 强制刷新透视表
pt.ManualUpdate = False
pt.RefreshTable
DoEvents
' 验证透视表数据
If pt.DataBodyRange Is Nothing Then
MsgBox "数据透视表没有数据，无法创建图表", vbExclamation
Exit Sub
End If
' 检查透视表范围是否有效
If pt.TableRange2 Is Nothing Then
MsgBox "数据透视表范围无效，无法创建图表", vbExclamation
Exit Sub
End If
' === 关键修复1：确保图表位置计算有效 ===
Dim chartTop As Long
On Error Resume Next
chartTop = pt.TableRange2.row + pt.TableRange2.rows.count + 2
If chartTop < 5 Then chartTop = 5 ' 确保最小位置
' === 关键修复2：安全创建图表对象 ===
Dim chtObj As ChartObject
Set chtObj = ws.ChartObjects.Add( _
Left:=50, _
Top:=chartTop, _
Width:=650, _
Height:=450)
Dim cht As Chart
Set cht = chtObj.Chart
' === 关键修复3：使用可靠的方式添加所有数据 ===
cht.SetSourceData Source:=pt.TableRange2
cht.chartType = xlLine
cht.HasTitle = True
cht.chartTitle.Text = chartTitle & " (含行总计)"
' === 关键修复4：确保行总计显示 ===
Dim srs As Series
Dim rowCount As Long: rowCount = pt.DataBodyRange.rows.count
Dim colCount As Long: colCount = pt.DataBodyRange.Columns.count
' 查找行总计列
Dim totalCol As Long
totalCol = FindTotalColumn(pt, False)
' 如果行总计列存在，确保它被标记为特殊系列
If totalCol > 0 Then
' 查找行总计系列并设置格式
Dim totalSeriesName As String
totalSeriesName = pt.ColumnRange.Cells(1, totalCol).value
For Each srs In cht.SeriesCollection
If srs.Name = totalSeriesName Then
With srs
.Border.Color = RGB(255, 0, 0) ' 红色线条
.MarkerStyle = xlMarkerStyleDiamond
.MarkerSize = 8
.Name = "行总计" ' 确保名称统一
End With
Exit For
End If
Next srs
Else
' 如果没有找到行总计列，手动添加
MsgBox "未找到行总计列，将手动计算添加", vbInformation
AddCalculatedTotalSeries cht, pt
End If
' === 关键修复5：修改日期标签角度 ===
FormatChart cht, False ' 传递参数控制标签角度
' 调试信息
Debug.Print "图表系列数量: " & cht.SeriesCollection.count
Debug.Print "行总计位置: " & totalCol
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
MsgBox "图表创建错误: " & Err.Description & vbCrLf & _
"错误号: " & Err.Number & vbCrLf & _
"位置: " & Erl, vbCritical
End Sub
' ===== 修改后的图表格式化函数 =====
Private Sub FormatChart(cht As Chart, Optional showDateDiagonal As Boolean = True)
On Error Resume Next
With cht
' 设置坐标轴
With .Axes(xlCategory)
.CategoryType = xlCategoryScale
.TickLabelSpacing = 1
' === 新增：控制日期标签角度 ===
If showDateDiagonal Then
.TickLabels.orientation = 45 ' 45度角显示日期
Else
.TickLabels.orientation = xlHorizontal ' 水平显示
End If
End With
' 设置数值轴
With .Axes(xlValue)
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(220, 220, 220)
.MinimumScale = 0 ' 从0开始
End With
' 设置图例
.HasLegend = True
.Legend.position = xlLegendPositionBottom
.Legend.Font.size = 9
' 设置绘图区域
.PlotArea.Border.Color = RGB(150, 150, 150)
End With
End Sub
' ===== 增强版查找总计列函数 =====
Private Function FindTotalColumn(pt As pivotTable, ByVal findColumnTotal As Boolean) As Long
On Error Resume Next
Dim headerCell As Range
Dim searchTerms As Variant
Dim i As Long
' 设置搜索术语（多语言支持）
searchTerms = Array("总计", "Total", "Grand Total", "汇总", "行总计", "Row Total")
' 遍历列标题查找匹配项
For i = 1 To pt.ColumnRange.Cells.count
Set headerCell = pt.ColumnRange.Cells(1, i)
' 检查是否匹配任何搜索术语
For Each term In searchTerms
If Not headerCell Is Nothing Then
If InStr(1, headerCell.value, term, vbTextCompare) > 0 Then
FindTotalColumn = i
Exit Function
End If
End If
Next term
Next i
' 后备方案：尝试最后一列（通常行总计在最后一列）
If pt.DataBodyRange.Columns.count > 0 Then
FindTotalColumn = pt.DataBodyRange.Columns.count
Else
FindTotalColumn = 0
End If
End Function
' ===== 添加计算的行总计系列 =====
Private Sub AddCalculatedTotalSeries(cht As Chart, pt As pivotTable)
On Error Resume Next
Dim srs As Series
Dim totalValues() As Double
Dim i As Long, j As Long
Dim dataRange As Range
Set dataRange = pt.DataBodyRange
If dataRange Is Nothing Then Exit Sub
ReDim totalValues(1 To dataRange.rows.count)
' 手动计算每行的总和
For i = 1 To dataRange.rows.count
totalValues(i) = 0
For j = 1 To dataRange.Columns.count
If IsNumeric(dataRange.Cells(i, j).value) Then
totalValues(i) = totalValues(i) + dataRange.Cells(i, j).value
End If
Next j
Next i
' 添加计算的行总计系列
Set srs = cht.SeriesCollection.NewSeries
With srs
.Name = "行总计 (计算)"
.values = totalValues
.xValues = pt.RowRange.Offset(1).Resize(dataRange.rows.count)
.Border.Color = RGB(255, 0, 0) ' 红色线条
.MarkerStyle = xlMarkerStyleDiamond
.MarkerSize = 8
End With
End Sub
' ===== 增强版获取行总计值函数 =====
Private Function GetRowTotalValues(pt As pivotTable) As Variant
On Error Resume Next
Dim dataRange As Range
Dim values() As Double
Dim i As Long, j As Long
Dim rowTotal As Double
Set dataRange = pt.DataBodyRange
If dataRange Is Nothing Then
ReDim values(1 To 1)
values(1) = 0
GetRowTotalValues = values
Exit Function
End If
Dim rowCount As Long
Dim colCount As Long
rowCount = dataRange.rows.count
colCount = dataRange.Columns.count
ReDim values(1 To rowCount)
' === 关键修改：正确处理行总计 ===
For i = 1 To rowCount
rowTotal = 0
For j = 1 To colCount
If pt.RowGrand And j = colCount Then ' 行总计列
rowTotal = dataRange.Cells(i, j).value
Exit For
Else
If IsNumeric(dataRange.Cells(i, j).value) Then
rowTotal = rowTotal + dataRange.Cells(i, j).value
End If
End If
Next j
values(i) = rowTotal
Next i
GetRowTotalValues = values
End Function
' ===== 增强版获取行总计函数 =====
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 - 1
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 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 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
最新发布
本文介绍了一种在不预先打开Excel文件的情况下，从C#程序中读取xlsx格式文件的方法。通过更改连接字符串中的提供者和扩展属性设置，可以避免出现“外部表不是预期格式”的错误。
扫一扫
31万+
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
