VBA循环遍历列表合并行并添加标题需求及代码优化求助

• 具备基础VBA能力，但对循环操作不熟悉
• 现有宏可运行，但存在错误且效率有待优化
• 需求：针对D列中的所有唯一State值，找到每个State的第一个出现实例，在其上方插入新行并合并该行作为对应标题行
• 当前代码存在的问题：
  • 硬编码固定的State值，若数据中无对应值会触发调试错误，添加On Error GoTo语句后仍无法跳过错误继续执行
  • 无法自动遍历D列所有不同的State值，每次数据更新后需手动修改代码

原代码 #

Sub InsertRow()

Application.ScreenUpdating = False

Dim rang As String
Dim Text2Find
Dim CopyTextRng As String
Dim Text As String

ActiveSheet.Range("A1").Select
Call FormatTable
'-------------------------------
On Error GoTo Err1

Text2Find = "Break"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err1:
On Error GoTo Err2
Text2Find = "Meal"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err2:
On Error GoTo Err3
Text2Find = "ManualSetACWPeriod"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err3:
On Error GoTo Err4
Text2Find = "OutboundCallResearch"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err4:
On Error GoTo Err5
Text2Find = "SystemFault"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err5:
On Error GoTo Err6
Text2Find = "ManagersDiscretion"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err6:
On Error GoTo Err7
Text2Find = "BuzzSession"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err7:
On Error GoTo Err8
Text2Find = "Coaching"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err8:
On Error GoTo Err9
Text2Find = "TeamMeeting"
Cells.Find(What:=Text2Find, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Call Merge

Err9:

Application.ScreenUpdating = True

Exit Sub

Application.ScreenUpdating = True

End Sub

'--------------------------------------------------------------------

Sub Merge()

Application.ScreenUpdating = True

Range(ActiveCell, ActiveCell.Offset(Val(1) - 1, 0)).EntireRow.Insert

rang = "A" & ActiveCell.Row & ":" & "G" & ActiveCell.Row
Range(rang).Merge

Range(rang).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    
CopyTextRng = "D" & ActiveCell.Row + 1
Text = UCase(Range(CopyTextRng).Value)

Range(rang) = Text

End Sub

解决方案 #

改进后的代码 #

Sub InsertStateHeaders()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim stateDict As Object
    Dim cell As Range
    Dim stateValue As String
    Dim foundCell As Range
    Dim insertRow As Long
    
    ' 关闭屏幕刷新提升效率
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    Set stateDict = CreateObject("Scripting.Dictionary")
    
    ' 获取D列最后一行行号
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    
    ' 遍历D列，收集所有唯一的State值
    For Each cell In ws.Range("D2:D" & lastRow) ' 假设D1是表头，从D2开始
        stateValue = Trim(cell.Value)
        If stateValue <> "" And Not stateDict.Exists(stateValue) Then
            stateDict.Add stateValue, True
        End If
    Next cell
    
    ' 遍历每个唯一State值，处理插入标题行
    For Each stateValue In stateDict.Keys
        ' 查找该State的第一个实例
        Set foundCell = ws.Range("D:D").Find(What:=stateValue, LookIn:=xlValues, LookAt:=xlWhole)
        If Not foundCell Is Nothing Then
            insertRow = foundCell.Row
            ' 在找到的行上方插入新行
            ws.Rows(insertRow).Insert Shift:=xlDown
            ' 合并新行的A到G列并设置格式
            With ws.Range("A" & insertRow & ":G" & insertRow)
                .Merge
                .Value = UCase(stateValue)
                .Interior.Color = 65535
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
            End With
        End If
    Next stateValue
    
    ' 恢复屏幕刷新并调用格式设置过程
    Application.ScreenUpdating = True
    Call FormatTable
End Sub

关键改进点 #

1. 自动收集唯一State值：使用Scripting.Dictionary遍历D列，自动获取所有不重复的State值，无需硬编码，适配任意数据
2. 错误规避：每次查找后判断foundCell是否存在，避免找不到值时触发错误
3. 效率优化：全程关闭ScreenUpdating，避免频繁刷新界面；使用对象引用替代Select/Activate，提升代码稳定性与运行速度
4. 代码简化：将合并单元格与格式设置合并到一个With块中，减少冗余代码
5. 逻辑修正：插入新行后直接操作目标单元格，避免因行插入导致的位置偏移问题

内容的提问来源于stack exchange，提问作者ajr45