请求协助合并两个Excel宏为单一宏（附现有宏代码）

我来帮你把这两个功能相似的宏合并成一个更高效的版本，同时优化原代码里的小问题，让操作流程更顺畅～

合并思路 #

两个宏都需要遍历NEW SHEET的C列，匹配Range("M17")的条件值。与其两次遍历整个工作表，不如一次遍历完成所有操作：找到符合条件的行后，先插入4个空白行，紧接着就从OLD SHEET复制指定行的数据粘贴到新插入的行中，这样既能减少重复操作，又能提升运行效率。

合并后的完整代码 #

Sub InsertAndPasteRows()
    Dim targetSheet As Worksheet
    Dim sourceSheet As Worksheet
    Dim matchValue As Variant
    Dim lastRow As Long
    Dim r As Long
    Dim pasteStartCell As Range
    
    ' 初始化对象和变量
    Set targetSheet = ThisWorkbook.Worksheets("NEW SHEET")
    Set sourceSheet = ThisWorkbook.Worksheets("OLD SHEET")
    matchValue = targetSheet.Range("M17").Value ' 确保从目标工作表取M17的值
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, "C").End(xlUp).Row
    
    ' 关闭屏幕更新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 从下往上遍历（避免插入行影响遍历顺序）
    For r = lastRow To 2 Step -1 ' 从第2行开始，跳过表头（如果有的话）
        If targetSheet.Cells(r, "C").Value = matchValue Then
            ' 插入4个空白行
            targetSheet.Rows(r + 1 & ":" & r + 4).Insert Shift:=xlDown
            
            ' 复制OLD SHEET中54-57行的可见单元格
            sourceSheet.Rows("54:57").SpecialCells(xlCellTypeVisible).Copy
            
            ' 粘贴到新插入的第一行（R+1行的A列）
            Set pasteStartCell = targetSheet.Cells(r + 1, "A")
            pasteStartCell.PasteSpecial Paste:=xlPasteAll ' 可以根据需求修改粘贴类型，比如xlPasteValues
            
            ' 清除剪贴板，避免残留内容
            Application.CutCopyMode = False
        End If
    Next r
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    ' 提示操作完成
    MsgBox "操作已完成！", vbInformation
End Sub

代码优化说明 #

1. 避免重复遍历：只遍历一次工作表，同时完成插入和粘贴操作，比原代码效率更高
2. 取消Select/Selection：直接通过工作表和单元格对象操作，避免因选中其他单元格导致的错误，代码更稳定
3. 明确对象归属：指定targetSheet和sourceSheet，避免因当前激活工作表变化而出错
4. 批量插入行：用Rows(r + 1 & ":" & r + 4).Insert替代四次单独插入，代码更简洁
5. 添加操作提示：完成后弹出提示框，让你清楚操作状态

原代码的问题修复 #

• 原第二个宏中Sheets(NEW SHEET).Select缺少引号，应该是Sheets("NEW SHEET").Select，合并后的代码直接用对象操作，避免了这个问题
• 原代码中PN_01的范围没有指定工作表，合并后明确从NEW SHEET取M17的值，避免歧义

额外优化建议 #

• 如果需要处理M17为空的情况，可以在代码开头添加判断：

  If IsEmpty(matchValue) Then
      MsgBox "请先在M17单元格输入匹配条件！", vbExclamation
      Exit Sub
  End If
  

• 可以添加错误处理，防止运行出错时屏幕更新无法恢复：

  On Error GoTo Cleanup
  ' 中间的代码...
  
  

Cleanup:
Application.ScreenUpdating = True
Application.CutCopyMode = False
If Err.Number <> 0 Then
MsgBox "运行出错：" & Err.Description, vbCritical
End If

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