基于B列值前4位相同的VBA循环复制单元格区域实现问询

需求说明 #

遍历B列，将B列前4位相同的连续行，复制对应的A列起始行至B列结束行的单元格区域（例如：B1、B2前4位为0501，则复制A1:B2；B3前4位为0502，则复制A3:B3）。

完善后的完整代码 #

Sub CopyByFirstFourChars()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim startRow As Long
    Dim i As Long
    Dim currentPrefix As String
    Dim nextPrefix As String
    
    ' 指定操作的工作表，可根据实际修改
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 获取B列最后一行有数据的行号，避免遍历整列浪费资源
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    ' 初始化相同前缀组的起始行
    startRow = 1
    
    For i = 1 To lastRow
        ' 提取当前行B列值的前4位
        currentPrefix = Left(ws.Cells(i, "B").Value, 4)
        
        ' 处理最后一行的边界情况，避免i+1越界
        If i = lastRow Then
            nextPrefix = ""
        Else
            nextPrefix = Left(ws.Cells(i + 1, "B").Value, 4)
        End If
        
        ' 当前前缀与下一行前缀不同时，确定区域并复制
        If currentPrefix <> nextPrefix Then
            ' 定义要复制的区域：A列起始行到B列当前行
            Dim copyRange As Range
            Set copyRange = ws.Range(ws.Cells(startRow, "A"), ws.Cells(i, "B"))
            
            ' --------------------------
            ' 此处添加你的粘贴操作，示例：
            ' copyRange.Copy Destination:=Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Offset(1, 0)
            ' --------------------------
            
            ' 调试用：打印复制区域的地址，实际使用可删除
            Debug.Print "复制区域：" & copyRange.Address
            
            ' 更新起始行为下一组的第一行
            startRow = i + 1
        End If
    Next i
End Sub

关键逻辑说明 #

• 避免无效遍历：用lastRow获取B列实际有数据的最后一行，替代原代码中遍历整列的操作，提升效率
• 起始/结束行控制：用startRow记录当前相同前缀组的起始行，当检测到下一行前缀不同（或当前是最后一行）时，将当前行设为结束行，从而确定要复制的区域
• 边界处理：单独判断最后一行，防止i+1超出数据范围导致报错

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