Excel检查建议子行插入按钮开发需求及代码问题咨询

需要创建用于跟踪检查、检查建议的日志及展示未完成建议的仪表盘。单条检查可对应多条建议，需实现点击按钮插入从Recommendation列（E列）开始的子行，并合并对应行的A-C列数据。现有VBA代码错误地合并了新行的A-C列（横向合并列），而非将新行的A-C列与上方检查行的A-C列纵向合并，无法实现需求。

示例表格 #

现有错误代码 #

Sub CreateAddRowButton()
    Dim btn As Button
    Dim ws As Worksheet
    
    ' Set the worksheet where the button will be added
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your target sheet name
    
    ' Create a button
    Set btn = ws.Buttons.Add(100, 10, 100, 30) ' Adjust the position and size as needed
    With btn
        .Caption = "Add Recommendation"
        .OnAction = "AddRecommendation"
    End With
End Sub

Sub AddRecommendation()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim newRow As Long
    
    ' Set the worksheet where data will be added
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your target sheet name
    
    On Error GoTo ErrorHandler ' Enable error handling
    
    ' Find the last row in column D
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    
    ' Determine the new row to insert data
    newRow = lastRow + 1
    
    ' Merge cells A, B, and C in the new row
    ws.Range("A" & newRow & ":C" & newRow).Merge
    ws.Range("A" & newRow).Value = "Recommendation" ' Change this to the appropriate value
    
    ' Populate the new recommendation from column D onward
    ws.Cells(newRow, 4).Value = "New Recommendation" ' Change this to the appropriate value
    
    ' Optional: Format the merged cells
    With ws.Range("A" & newRow)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = True
    End With
    
    ' Inform the user of success
    MsgBox "New recommendation added successfully!", vbInformation

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical
End Sub

修正后的代码 #

Sub CreateAddRowButton()
    Dim btn As Button
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 替换为你的工作表名称
    Set btn = ws.Buttons.Add(100, 10, 100, 30) ' 调整按钮位置和大小
    With btn
        .Caption = "添加建议"
        .OnAction = "AddRecommendation"
    End With
End Sub

Sub AddRecommendation()
    Dim ws As Worksheet
    Dim targetRow As Long
    Dim newRow As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 替换为你的工作表名称
    On Error GoTo ErrorHandler

    ' 获取当前选中行（若未选中则取最后一条检查行）
    If Selection.Rows.Count > 0 Then
        targetRow = Selection.Row
        ' 确保选中的是有检查数据的行（A列非空）
        If ws.Cells(targetRow, "A").Value = "" Then
            MsgBox "请选中一条检查记录行", vbExclamation
            Exit Sub
        End If
    Else
        ' 自动找到最后一条有检查数据的行（A列非空）
        targetRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        If targetRow < 2 Then ' 假设第一行是表头
            MsgBox "请先添加检查记录", vbExclamation
            Exit Sub
        End If
    End If

    ' 在目标行下方插入新行
    newRow = targetRow + 1
    ws.Rows(newRow).Insert Shift:=xlDown

    ' 合并目标行与新行的A-C列（纵向合并行）
    ws.Range("A" & targetRow & ":C" & newRow).Merge
    ' 设置合并单元格对齐方式
    With ws.Range("A" & targetRow)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    ' 清空新行D列，在E列填入默认建议文本
    ws.Cells(newRow, "D").ClearContents
    ws.Cells(newRow, "E").Value = "新建议" ' 可自定义默认文本

    MsgBox "新建议行已添加", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "发生错误: " & Err.Description, vbCritical
End Sub

关键修改说明 #

• 选中行识别：支持用户选中指定检查行添加子建议，若未选中则自动定位最后一条检查记录行
• 纵向合并行：将目标检查行与新插入行的A-C列合并，实现单条检查对应多条建议的视觉关联
• 子行数据处理：清空新行的D列（Area of non-compliance），从E列（Recommendation）开始填充建议内容，匹配示例表格格式
• 错误提示优化：增加场景化提示，引导用户正确操作

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