基于两个区域单元格值匹配插入指定行

我来帮你搞定这个跨工作簿的唯一值识别与行插入需求，下面是完整的VBA代码实现，我会针对你标记的****Need help here部分重点拆解逻辑：

Sub CopyUniqueRowsAndInsert()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim rng1 As Range, rng2 As Range
    Dim cell As Range
    Dim uniqueVal As Variant
    Dim matchRow As Long
    Dim insertRow As Long
    
    ' 定义两个工作簿（这里假设你已经打开了目标工作簿，可根据实际情况调整）
    Set wb1 = Workbooks("Workbook1.xlsx") ' Range1所在工作簿
    Set wb2 = Workbooks("Workbook2.xlsx") ' Range2所在工作簿
    
    ' 定义两个目标区域（示例为A列，可根据实际范围修改）
    Set rng1 = wb1.Sheets("Sheet1").Range("A2:A100") ' Range1：唯一值检测区域
    Set rng2 = wb2.Sheets("Sheet1").Range("A2:A100") ' Range2：匹配与插入区域
    
    ' 遍历Range1中的每个单元格，识别唯一值
    For Each cell In rng1
        uniqueVal = cell.Value
        ' 检查当前值在Range1中是否是唯一值
        If WorksheetFunction.CountIf(rng1, uniqueVal) = 1 Then
            ' ****Need help here 核心处理逻辑开始****
            ' 1. 在Range2中找到该唯一值的匹配行
            On Error Resume Next
            matchRow = WorksheetFunction.Match(uniqueVal, rng2, 0) + rng2.Row - 1 ' 转换为实际行号
            On Error GoTo 0
            
            If matchRow > 0 Then
                ' 2. 找到Range1中唯一值正下方的非唯一值行
                Dim nextCell As Range
                Set nextCell = cell.Offset(1, 0)
                ' 向下遍历直到找到非唯一值（或区域末尾）
                Do While Not nextCell Is Nothing And WorksheetFunction.CountIf(rng1, nextCell.Value) = 1
                    Set nextCell = nextCell.Offset(1, 0)
                Loop
                
                ' 3. 在找到的非唯一值上方插入行，并复制唯一值所在行的内容
                If Not nextCell Is Nothing Then
                    insertRow = nextCell.Row
                    ' 插入空白行
                    wb1.Sheets("Sheet1").Rows(insertRow).Insert Shift:=xlDown
                    ' 复制唯一值所在行到插入的空白行
                    cell.EntireRow.Copy Destination:=wb1.Sheets("Sheet1").Rows(insertRow)
                End If
                
                ' 4. 将选中的行复制插入到Range2中的相对位置（匹配行的下方）
                cell.EntireRow.Copy
                wb2.Sheets("Sheet1").Rows(matchRow + 1).Insert Shift:=xlDown
                Application.CutCopyMode = False ' 清除复制状态
            End If
            ' ****Need help here 核心处理逻辑结束****
        End If
    Next cell
    
    MsgBox "操作完成！"
End Sub

关键逻辑解释 #

• 跨工作簿引用：代码中直接通过Workbooks("文件名")和Sheets("表名")定位不同工作簿的区域，确保在同一Excel实例下可以正常访问。如果需要自动打开工作簿，可以添加Set wb1 = Workbooks.Open("C:\路径\Workbook1.xlsx")这类语句。
• 唯一值识别：用CountIf函数判断当前单元格值在Range1中是否仅出现一次，以此标记唯一值。
• 相对位置插入：
  1. 用Match函数在Range2中找到唯一值的对应行，转换为实际行号后，在其下方插入复制的行，保证相对位置一致。
  2. 遍历Range1中唯一值的下方单元格，跳过连续的唯一值，直到找到第一个非唯一值，然后在该行上方插入复制的唯一值行。
• 错误处理：加入On Error Resume Next避免因唯一值在Range2中不存在导致的程序崩溃，后续会通过matchRow > 0判断是否找到匹配项。

使用注意事项 #

• 请根据实际数据范围调整rng1和rng2的区域，比如如果数据在A到E列，可改为Range("A2:E100")。
• 如果不需要复制整行，可将cell.EntireRow替换为指定列范围，比如cell.Resize(1, 5)表示复制当前行前5列。
• 运行前请确保两个工作簿处于同一Excel实例中，避免跨实例访问的权限问题。

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