Option Explicit
Sub GenerateSatelliteProgramReport()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' 获取源数据表
Dim srcSheet As Worksheet
Set srcSheet = ThisWorkbook.Sheets("告警记录")
' 删除旧工作表(如果存在)
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("卫星节目故障统计表").Delete
ThisWorkbook.Sheets("卫星节目汇总分析表").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' ==== 创建卫星节目故障统计表 ====
Dim statSheet As Worksheet
Set statSheet = ThisWorkbook.Sheets.Add(After:=srcSheet)
statSheet.Name = "卫星节目故障统计表"
' 复制表头
Dim srcHeader As String
srcHeader = srcSheet.Range("A1").Value
With statSheet.Range("A1:F1")
.Merge
.Value = srcHeader
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
' 设置标题行
statSheet.Range("A2:F2") = Array("影响卫星", "影响节目", "故障类型", "发生时间", "结束时间", "持续时间(秒)")
statSheet.Rows(2).Font.Bold = True
statSheet.Range("A2:F2").HorizontalAlignment = xlCenter
' 处理数据并填充统计表
Dim lastRow As Long, statRow As Long
lastRow = srcSheet.Cells(srcSheet.Rows.Count, "C").End(xlUp).Row
statRow = 3
Dim dataRow As Range, signalCell As Range
For Each dataRow In srcSheet.Range("C3:C" & lastRow).Rows
Set signalCell = dataRow.Cells(1, 1)
Dim signalStr As String, satellite As String, programStr As String
signalStr = CStr(signalCell.Value)
' 解析卫星和节目名称
Dim lastUnderscorePos As Long
lastUnderscorePos = InStrRev(signalStr, "_")
If lastUnderscorePos = 0 Then GoTo NextRow
satellite = Mid(signalStr, lastUnderscorePos + 1)
programStr = Left(signalStr, lastUnderscorePos - 1)
Dim programs() As String
programs = Split(programStr, "/")
' 获取关联数据
Dim occurTime As Date, resumeTime As Date, faultTypeStr As String
occurTime = signalCell.Offset(0, 3).Value ' F列
resumeTime = signalCell.Offset(0, 4).Value ' G列
faultTypeStr = signalCell.Offset(0, 2).Value ' E列
Dim durationSeconds As Long
durationSeconds = ConvertDurationToSeconds(signalCell.Offset(0, 5).Value) ' H列
' 填充数据
Dim i As Integer
For i = 0 To UBound(programs)
statSheet.Cells(statRow, 1) = satellite ' A列: 影响卫星
statSheet.Cells(statRow, 2) = programs(i) ' B列: 影响节目
statSheet.Cells(statRow, 3) = faultTypeStr ' C列: 故障类型
statSheet.Cells(statRow, 4) = occurTime ' D列: 发生时间
statSheet.Cells(statRow, 5) = resumeTime ' E列: 结束时间
statSheet.Cells(statRow, 6) = durationSeconds ' F列: 持续时间
statRow = statRow + 1
Next i
NextRow:
Next dataRow
' 设置统计表格式
If statRow > 3 Then
With statSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=statSheet.Range("D3:D" & statRow - 1), Order:=xlAscending ' 发生时间
.SortFields.Add Key:=statSheet.Range("B3:B" & statRow - 1), Order:=xlAscending ' 影响节目
.SetRange statSheet.Range("A3:F" & statRow - 1)
.Header = xlNo
.Apply
End With
statSheet.Range("D3:E" & statRow - 1).NumberFormat = "yyyy-mm-dd hh:mm:ss"
statSheet.Range("F3:F" & statRow - 1).NumberFormat = "0"
statSheet.Columns("A:F").AutoFit
statSheet.Range("A1").HorizontalAlignment = xlCenter
statSheet.Range("A2:F2").HorizontalAlignment = xlCenter
statSheet.Range("A3:F" & statRow - 1).HorizontalAlignment = xlCenter
' ==== 冻结前两行 ====
statSheet.Activate
statSheet.Range("A3").Select
ActiveWindow.FreezePanes = True
End If
' ==== 创建卫星节目汇总分析表 ====
Dim analysisSheet As Worksheet
Set analysisSheet = ThisWorkbook.Sheets.Add(After:=statSheet)
analysisSheet.Name = "卫星节目汇总分析表"
' 分析表表头 (合并A1:H1)
With analysisSheet.Range("A1:H1")
.Merge
.Value = srcHeader
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
' 分析表标题行 (8列) - 精确顺序
analysisSheet.Range("A2:H2") = Array("影响卫星", "影响节目", "故障类型", "发生日期", "发生时间", "结束时间", "持续时间(秒)", "累加时间(秒)")
analysisSheet.Rows(2).Font.Bold = True
analysisSheet.Range("A2:H2").HorizontalAlignment = xlCenter
' 汇总分析处理
If statRow <= 3 Then
MsgBox "统计表中无数据,跳过汇总分析"
GoTo Finalize
End If
Dim analysisRow As Long: analysisRow = 3
' 创建三层字典: 节目 -> 故障类型 -> 日期
Dim programDict As Object
Set programDict = CreateObject("Scripting.Dictionary")
' 创建节目到卫星的映射字典
Dim programToSatellite As Object
Set programToSatellite = CreateObject("Scripting.Dictionary")
' 遍历统计表数据
Dim r As Long
For r = 3 To statRow - 1
Dim programName As String
programName = statSheet.Cells(r, 2).Value ' B列: 影响节目
Dim satelliteName As String
satelliteName = statSheet.Cells(r, 1).Value ' A列: 影响卫星
' 保存节目到卫星的映射
If Not programToSatellite.Exists(programName) Then
programToSatellite.Add programName, satelliteName
End If
Dim faultType As String
faultType = statSheet.Cells(r, 3).Value ' C列: 故障类型
Dim occurDate As String
occurDate = Format(statSheet.Cells(r, 4).Value, "yyyy-mm-dd") ' D列: 发生时间 -> 日期
' 创建三层字典结构
If Not programDict.Exists(programName) Then
programDict.Add programName, CreateObject("Scripting.Dictionary")
End If
Dim faultTypeDict As Object
Set faultTypeDict = programDict(programName)
If Not faultTypeDict.Exists(faultType) Then
faultTypeDict.Add faultType, CreateObject("Scripting.Dictionary")
End If
Dim dateDict As Object
Set dateDict = faultTypeDict(faultType)
If Not dateDict.Exists(occurDate) Then
dateDict.Add occurDate, New Collection
End If
' 添加行号到对应集合
dateDict(occurDate).Add r
Next r
' 遍历字典并填充分析表 - 使用精确列顺序
Dim programKey As Variant, faultTypeKey As Variant, dateKey As Variant
For Each programKey In programDict.Keys
' 从映射字典获取卫星名称
satelliteName = programToSatellite(programKey)
Set faultTypeDict = programDict(programKey)
For Each faultTypeKey In faultTypeDict.Keys
Set dateDict = faultTypeDict(faultTypeKey)
For Each dateKey In dateDict.Keys
Dim minOccurTime As Date, maxResumeTime As Date
Dim totalDuration As Long
minOccurTime = #1/1/9999# ' 初始化为极大值
maxResumeTime = #1/1/100# ' 初始化为极小值
totalDuration = 0
' 遍历该分组的所有行
Dim rowItem As Variant
For Each rowItem In dateDict(dateKey)
r = rowItem
' 更新最小发生时间
If statSheet.Cells(r, 4).Value < minOccurTime Then
minOccurTime = statSheet.Cells(r, 4).Value
End If
' 更新最大结束时间
If statSheet.Cells(r, 5).Value > maxResumeTime Then
maxResumeTime = statSheet.Cells(r, 5).Value
End If
' 累加持续时间
totalDuration = totalDuration + statSheet.Cells(r, 6).Value
Next rowItem
' 计算新的持续时间(秒)
Dim newDuration As Long
newDuration = DateDiff("s", minOccurTime, maxResumeTime)
' 填充分析表 - 精确列顺序
analysisSheet.Cells(analysisRow, 1) = satelliteName ' A列: 影响卫星
analysisSheet.Cells(analysisRow, 2) = programKey ' B列: 影响节目
analysisSheet.Cells(analysisRow, 3) = faultTypeKey ' C列: 故障类型
analysisSheet.Cells(analysisRow, 4) = dateKey ' D列: 发生日期
analysisSheet.Cells(analysisRow, 5) = minOccurTime ' E列: 发生时间
analysisSheet.Cells(analysisRow, 6) = maxResumeTime ' F列: 结束时间
analysisSheet.Cells(analysisRow, 7) = newDuration ' G列: 持续时间(秒)
analysisSheet.Cells(analysisRow, 8) = totalDuration ' H列: 累加时间(秒)
analysisRow = analysisRow + 1
Next dateKey
Next faultTypeKey
Next programKey
' 设置分析表格式
If analysisRow > 3 Then
' 日期时间格式
analysisSheet.Columns("D").NumberFormat = "yyyy-mm-dd" ' 发生日期
analysisSheet.Columns("E:F").NumberFormat = "yyyy-mm-dd hh:mm:ss" ' 发生时间/结束时间
analysisSheet.Columns("G:H").NumberFormat = "0" ' 持续时间/累加时间
' ==== 按多级排序 ====
With analysisSheet.Sort
.SortFields.Clear
' 第一级:影响卫星(A列)升序
.SortFields.Add Key:=analysisSheet.Range("A3:A" & analysisRow - 1), _
Order:=xlAscending
' 第二级:影响节目(B列)升序
.SortFields.Add Key:=analysisSheet.Range("B3:B" & analysisRow - 1), _
Order:=xlAscending
' 第三级:故障类型(C列)升序
.SortFields.Add Key:=analysisSheet.Range("C3:C" & analysisRow - 1), _
Order:=xlAscending
' 第四级:发生日期(D列)降序
.SortFields.Add Key:=analysisSheet.Range("D3:D" & analysisRow - 1), _
Order:=xlDescending
.SetRange analysisSheet.Range("A3:H" & analysisRow - 1)
.Header = xlNo
.Apply
End With
' ==== 逐级合并单元格 ====
Application.ScreenUpdating = False
' 1. 先合并卫星列(A列)
MergeSimilarCells analysisSheet, "A", 3, analysisRow - 1
' 2. 在卫星列合并的基础上合并节目列(B列)
MergeSimilarCellsWithParent analysisSheet, "A", "B", 3, analysisRow - 1
' 3. 在前两列合并的基础上合并故障类型列(C列)
MergeSimilarCellsWithParent analysisSheet, "B", "C", 3, analysisRow - 1
' 4. 在前三列合并的基础上合并发生日期列(D列)
MergeSimilarCellsWithParent analysisSheet, "C", "D", 3, analysisRow - 1
Application.ScreenUpdating = True
' 自动调整列宽
analysisSheet.Columns("A:H").AutoFit
analysisSheet.Range("A3:H" & analysisRow - 1).HorizontalAlignment = xlCenter
' 设置标题行格式
analysisSheet.Rows(2).Font.Bold = True
analysisSheet.Range("A2:H2").HorizontalAlignment = xlCenter
analysisSheet.Range("A1:H2").EntireRow.AutoFit
' ==== 冻结前两行 ====
analysisSheet.Activate
analysisSheet.Range("A3").Select
ActiveWindow.FreezePanes = True
' ==== 高亮关键单元格 ====
HighlightCriticalCells analysisSheet, analysisRow - 1
End If
Finalize:
MsgBox "生成完成!统计表处理 " & statRow - 3 & " 条记录,分析表生成 " & analysisRow - 3 & " 条记录。"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrorHandler:
MsgBox "错误 " & Err.Number & ": " & Err.Description & vbCrLf & _
"位置: " & Erl, vbCritical, "运行时错误"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
' 高亮关键单元格
Sub HighlightCriticalCells(sht As Worksheet, lastRow As Long)
If lastRow < 3 Then Exit Sub
' 清除旧的高亮
sht.Range("E3:H" & lastRow).Interior.Pattern = xlNone
' 1. 处理发生时间列(E列) - 最小值
Dim minDate As Date, minTime As Date, minRow As Long
minDate = #12/31/9999# ' 初始化为最大日期
minTime = #11:59:59 PM# ' 初始化为最大时间
Dim r As Long
For r = 3 To lastRow
Dim cellDate As Date, cellTime As Date
cellDate = Int(sht.Cells(r, "E").Value) ' 日期部分
cellTime = sht.Cells(r, "E").Value - Int(sht.Cells(r, "E").Value) ' 时间部分
' 先比较日期
If cellDate < minDate Then
minDate = cellDate
minTime = cellTime
minRow = r
ElseIf cellDate = minDate Then
' 同一天再比较时间
If cellTime < minTime Then
minTime = cellTime
minRow = r
End If
End If
Next r
sht.Cells(minRow, "E").Interior.Color = vbYellow
' 2. 处理结束时间列(F列) - 最大值
Dim maxDate As Date, maxTime As Date, maxRow As Long
maxDate = #1/1/100# ' 初始化为最小日期
maxTime = #12:00:00 AM# ' 初始化为最小时间
For r = 3 To lastRow
cellDate = Int(sht.Cells(r, "F").Value)
cellTime = sht.Cells(r, "F").Value - Int(sht.Cells(r, "F").Value)
If cellDate > maxDate Then
maxDate = cellDate
maxTime = cellTime
maxRow = r
ElseIf cellDate = maxDate Then
If cellTime > maxTime Then
maxTime = cellTime
maxRow = r
End If
End If
Next r
sht.Cells(maxRow, "F").Interior.Color = vbYellow
' 3. 处理持续时间列(G列) - 最大值
Dim maxDuration As Long, maxDurationRow As Long
maxDuration = -1
For r = 3 To lastRow
If sht.Cells(r, "G").Value > maxDuration Then
maxDuration = sht.Cells(r, "G").Value
maxDurationRow = r
End If
Next r
sht.Cells(maxDurationRow, "G").Interior.Color = vbYellow
' 4. 处理累加时间列(H列) - 最大值
Dim maxAccumulated As Long, maxAccumulatedRow As Long
maxAccumulated = -1
For r = 3 To lastRow
If sht.Cells(r, "H").Value > maxAccumulated Then
maxAccumulated = sht.Cells(r, "H").Value
maxAccumulatedRow = r
End If
Next r
sht.Cells(maxAccumulatedRow, "H").Interior.Color = vbYellow
End Sub
' 合并相同内容的单元格(基础版)
Sub MergeSimilarCells(sht As Worksheet, col As String, startRow As Long, endRow As Long)
If startRow >= endRow Then Exit Sub
Dim currentValue As Variant, mergeStart As Long, r As Long
currentValue = sht.Cells(startRow, col).Value
mergeStart = startRow
For r = startRow + 1 To endRow
If sht.Cells(r, col).Value <> currentValue Then
If r - mergeStart > 1 Then
With sht.Range(col & mergeStart & ":" & col & (r - 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
currentValue = sht.Cells(r, col).Value
mergeStart = r
End If
Next r
If endRow - mergeStart >= 1 Then
With sht.Range(col & mergeStart & ":" & col & endRow)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End Sub
' 基于父列合并单元格(逐级合并)
Sub MergeSimilarCellsWithParent(sht As Worksheet, parentCol As String, childCol As String, _
startRow As Long, endRow As Long)
If startRow >= endRow Then Exit Sub
Dim r As Long, currentParentRange As Range
Dim childStartRow As Long, childCurrentValue As Variant
' 遍历所有父级合并区域
For Each currentParentRange In sht.Range(parentCol & startRow & ":" & parentCol & endRow).Areas
' 跳过单个单元格
If currentParentRange.Cells.Count = 1 Then
' 单个单元格不合并,但居中处理
With sht.Cells(currentParentRange.Row, childCol)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
GoTo NextParent
End If
' 获取子列在父区域内的起始行
childStartRow = currentParentRange.Row
childCurrentValue = sht.Cells(childStartRow, childCol).Value
' 遍历父区域内的所有行
Dim rInParent As Long
For rInParent = childStartRow + 1 To childStartRow + currentParentRange.Rows.Count - 1
' 当值变化时,合并前一组的单元格
If sht.Cells(rInParent, childCol).Value <> childCurrentValue Then
' 合并连续相同值的单元格
If rInParent - childStartRow > 1 Then
With sht.Range(childCol & childStartRow & ":" & childCol & (rInParent - 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
childCurrentValue = sht.Cells(rInParent, childCol).Value
childStartRow = rInParent
End If
Next rInParent
' 处理父区域内的最后一段
If (currentParentRange.Row + currentParentRange.Rows.Count - 1) - childStartRow >= 1 Then
With sht.Range(childCol & childStartRow & ":" & childCol & (currentParentRange.Row + currentParentRange.Rows.Count - 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Else
' 处理单个单元格情况
With sht.Cells(childStartRow, childCol)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
NextParent:
Next currentParentRange
End Sub
' 将持续时间字符串转换为秒数
Function ConvertDurationToSeconds(durationStr As String) As Long
On Error Resume Next
Dim parts() As String
parts = Split(durationStr, ":")
If UBound(parts) >= 2 Then
' 格式为 hh:mm:ss
ConvertDurationToSeconds = Val(parts(0)) * 3600 + Val(parts(1)) * 60 + Val(parts(2))
ElseIf UBound(parts) = 1 Then
' 格式为 mm:ss
ConvertDurationToSeconds = Val(parts(0)) * 60 + Val(parts(1))
ElseIf UBound(parts) = 0 Then
' 格式为 ss
ConvertDurationToSeconds = Val(parts(0))
Else
ConvertDurationToSeconds = 0
End If
If Err.Number <> 0 Then
ConvertDurationToSeconds = 0
End If
End Function
最新发布