VBA开发:如何利用ActiveWindow对象的属性实现窗格的拆分和冻结?

本文介绍了如何使用VBA在Excel中通过Select方法和FreezePans/SplitRow/SplitColumn属性进行窗格的拆分与冻结,以及如何安全地取消这些操作。

摘要生成于 C知道 ,由 DeepSeek-R1 满血版支持, 前往体验 >

       

目录

1.使用Select方法和FreezePans属性拆分和冻结窗格

2.使用SplitRow、SplitColumn和FreezePans属性拆分和冻结窗格

3.窗格拆分和冻结的取消


         用户界面是任何程序设计都很重要的一环,直接影响到使用者的感受。对于我们VBA开发来说,我们将数据按照要求抓取出来之后,通常要以某种适宜的形式展现给用户。这时候就需要用到窗格的拆分、冻结。

        窗格的拆分、冻结,需要用到ActiveWindow对象。ActiveWindow对象是Window对象的一个实例,指代的是excel应用中当前活动的窗口。我们使用这个实例的Split 属性和FreezePans属性,就可以实现拆分和冻结。

        在使用FreezePans属性时,需要注意以下两点:

  1. 使用FreezePans=True时,如果Split=True,那么就按照Splitcolumn和Splitrow指定的值来冻结窗格。
  2. 使用FreezePans=True时,如果Split=False,则按照当前活动单元格的Row-1,Column-1来冻结窗格。

        由此我们有两种不同的方法来实现拆分和冻结窗格。

1.使用Select方法和FreezePans属性拆分和冻结窗格

这个例程我们首先选定单元格(3,4),然后将ActiveWindow的Split属性设置为False,然后将FreezePanes属性设置为True。大家可以发现,窗格会以Row=2,Column=3拆分并冻结。

 

Public Function splitwindow1()
    '选定单元格
    Sheet5.Cells(3, 4).Select
    '按选定单元格的Row-1,Column-1来冻结窗格
    With ActiveWindow
        .Split = False
        .FreezePanes = True
    End With
End Function

 

2.使用SplitRow、SplitColumn和FreezePans属性拆分和冻结窗格

        这个例程,我们直接使用SplitRow和SplitColumn属性指定以Row=1和Column=3来拆分,然后使用FreezePans属性来冻结窗格。

Public Function splitwindow2()
    '使用SplitRow和SplitColumn来拆分和冻结窗格
    With ActiveWindow
        .SplitRow = 1
        .SplitColumn = 3
        .FreezePanes = True
    End With
End Function

 

3.窗格拆分和冻结的取消

        拆分的取消有两种方法,一种是直接将Split属性设置为False,但是这种方法并不改变SplitRow和SplitColumn的值,所以并不安全,下次可能会出现误操作。另一种是将SplitRow和SplitColumn属性设置为0,这时候自动就将Split属性设置为False了。

        冻结的取消很简单,直接将FreezePanes属性设置为False就可以了。

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
最新发布
07-10
评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

ZevieZ

你的鼓励将是我创作的最大动力

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付:¥1
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值