VBA技术求助：如何插入行并分组数据？附数据复制代码问题

让我逐个帮你解决这两个VBA问题：

插入行并分组的核心是先通过Rows.Insert插入目标行，再用Range.Group方法对插入的行进行分组。下面给你两种常见场景的示例：

场景1：在指定位置插入固定行数并分组 #

比如要在第5行下方插入3行，然后把这3行折叠分组：

Sub InsertRowsAndGroup()
    Dim insertPosition As Integer
    Dim numRowsToInsert As Integer
    
    insertPosition = 5 ' 要在第5行下方插入
    numRowsToInsert = 3 ' 插入3行
    
    ' 关闭屏幕更新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 插入行
    Rows(insertPosition + 1 & ":" & insertPosition + numRowsToInsert).Insert Shift:=xlDown
    
    ' 对插入的行进行分组（默认是行分组，方向向上折叠）
    Rows(insertPosition + 1 & ":" & insertPosition + numRowsToInsert).Group
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

场景2：根据条件插入行并分组（比如按列值分组） #

假设你要在A列值变化的地方插入一行，然后将相同值的行分组：

Sub InsertAndGroupByCondition()
    Dim lastRow As Long
    Dim i As Long
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    ' 从下往上遍历，避免插入行影响循环计数
    For i = lastRow To 2 Step -1
        If Cells(i, "A").Value <> Cells(i - 1, "A").Value Then
            ' 在当前行上方插入一行
            Rows(i).Insert Shift:=xlDown
            ' 将上一组数据分组（从当前组的起始行到i-1行）
            ' 这里需要根据你的实际起始行调整，假设第一组从第2行开始
            Rows(2 & ":" & i - 1).Group
        End If
    Next i
    
    ' 最后一组数据分组
    Rows(2 & ":" & lastRow + 1).Group ' 因为插入了行，lastRow需要+1
    
    Application.ScreenUpdating = True
End Sub

注意：分组后默认是折叠状态，如果你想默认展开，可以设置Rows(x).ShowDetail = True。

先看你的现有代码，发现几个小问题：一是sourceCel...是sourceCell的拼写错误；二是缺少复制数据的核心逻辑，也没有错误处理（比如目标工作表不存在的情况）。下面给你补全并优化后的代码：

Sub Copypastemeddata()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim sourceCell As Range
    Dim targetSheet As Worksheet
    Dim StartRow As Integer
    Dim sourceDataRange As Range ' 存储要复制的数据范围
    Dim lastSourceRow As Long ' 源数据的最后一行
    
    ' 关闭屏幕更新和事件，提升性能
    Application.ScreenUpdating = False
    Application.CopyObjectsWithCells = False
    Application.EnableEvents = False
    
    On Error GoTo Cleanup ' 错误处理，确保异常时能恢复设置
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Opgørsel")
    Set sourceCell = ws.Range("D3") ' 存储目标工作表名称的单元格
    
    ' 检查目标工作表名称是否为空
    If sourceCell.Value = "" Then
        MsgBox "D3单元格未填写目标工作表名称！", vbExclamation
        GoTo Cleanup
    End If
    
    ' 尝试设置目标工作表，处理工作表不存在的情况
    On Error Resume Next
    Set targetSheet = wb.Worksheets(sourceCell.Value)
    On Error GoTo Cleanup
    If targetSheet Is Nothing Then
        MsgBox "不存在名为" & sourceCell.Value & "的工作表！", vbCritical
        GoTo Cleanup
    End If
    
    StartRow = 1 ' 目标工作表的起始行
    
    ' 假设你要复制Opgørsel工作表中D列从D4开始到最后一行的数据
    ' 如果你要复制其他范围，修改这里的列和起始行即可
    lastSourceRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    If lastSourceRow >= 4 Then ' 确保有数据可复制
        Set sourceDataRange = ws.Range("D4:D" & lastSourceRow)
        ' 复制到目标工作表的StartRow行开始的D列（可修改目标列）
        sourceDataRange.Copy Destination:=targetSheet.Cells(StartRow, "D")
        ' 如果只需要值，不需要格式，可以用下面的代码，更高效
        ' targetSheet.Cells(StartRow, "D").Resize(sourceDataRange.Rows.Count).Value = sourceDataRange.Value
    Else
        MsgBox "Opgørsel工作表中没有可复制的数据！", vbInformation
    End If
    
Cleanup:
    ' 恢复所有应用设置
    Application.ScreenUpdating = True
    Application.CopyObjectsWithCells = True
    Application.EnableEvents = True
    ' 释放对象变量
    Set wb = Nothing
    Set ws = Nothing
    Set sourceCell = Nothing
    Set targetSheet = Nothing
    Set sourceDataRange = Nothing
End Sub

代码说明： #

• 增加了错误处理：如果D3为空、目标工作表不存在，会弹出提示并优雅退出
• 增加了数据范围判断：确保有数据才进行复制操作
• 提供了两种复制方式：带格式的Copy和只复制值的直接赋值（后者更高效）
• 最后恢复了所有应用设置，避免影响后续操作

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