基于连续值拼接字段：Excel VBA代码优化需求

首先，我先明确你的需求细节（从你的示例输出反推）：

• 对于值为0的行：
  • 若当前0属于连续4个0的序列，则在该序列的第一个0行，拼接「序列前最近的非0字段 + 连续4个0的所有字段」（比如F2-F5是4个连续0，所以拼接F1|F2|F3|F4|F5）
  • 若当前0是单个/连续不足4个的0，则拼接「前一个非0字段 + 当前字段」（比如F8是单个0，拼接F7|F8）
• 连续4个0的后续行（F3-F5）只保留0，不需要拼接
• 非0行无需处理拼接

你的原代码问题在于：

• 仅简单将当前字段与上一行字段拼接，没有区分连续0的场景，也没处理连续4个0的特殊逻辑
• 使用FormulaR1C1在20万行数据上会产生巨大性能开销，公式反复计算会导致卡顿

下面是优化后的VBA代码，用数组处理提升效率，同时精准匹配你的需求：

Sub ProcessZeroRows()
    Dim ws As Worksheet
    Dim dataArr As Variant
    Dim resultArr As Variant
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim zeroStart As Long
    Dim zeroCount As Long
    Dim prevNonZeroCol1 As String
    
    ' 设置目标工作表，可根据实际修改
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 一次性读取数据到数组，大幅提升处理速度
    dataArr = ws.Range("A1:B" & lastRow).Value
    ReDim resultArr(1 To lastRow, 1 To 1) ' 存储拼接结果
    
    ' 初始化第一个非0字段
    prevNonZeroCol1 = dataArr(1, 1)
    If dataArr(1, 2) = 0 Then
        zeroStart = 1
        zeroCount = 1
    Else
        resultArr(1, 1) = ""
    End If
    
    ' 从第二行开始遍历数据
    For i = 2 To lastRow
        If dataArr(i, 2) = 0 Then
            zeroCount = zeroCount + 1
            If zeroCount = 1 Then zeroStart = i
        Else
            ' 遇到非0行，处理之前的连续0序列
            If zeroCount >= 1 Then
                If zeroCount = 4 Then
                    ' 连续4个0：在第一个0行拼接完整序列
                    Dim concatStr As String
                    concatStr = prevNonZeroCol1
                    For j = zeroStart To zeroStart + 3
                        concatStr = concatStr & "|" & dataArr(j, 1)
                    Next j
                    resultArr(zeroStart, 1) = concatStr
                ElseIf zeroCount = 1 Then
                    ' 单个0：拼接前非0字段+当前字段
                    resultArr(zeroStart, 1) = prevNonZeroCol1 & "|" & dataArr(zeroStart, 1)
                End If
                ' 重置连续0计数器
                zeroCount = 0
            End If
            ' 更新前一个非0字段
            prevNonZeroCol1 = dataArr(i, 1)
            resultArr(i, 1) = ""
        End If
    Next i
    
    ' 处理最后一行是0的边界情况
    If zeroCount >= 1 Then
        If zeroCount = 4 Then
            Dim finalConcatStr As String
            finalConcatStr = prevNonZeroCol1
            For j = zeroStart To zeroStart + 3
                finalConcatStr = finalConcatStr & "|" & dataArr(j, 1)
            Next j
            resultArr(zeroStart, 1) = finalConcatStr
        ElseIf zeroCount = 1 Then
            resultArr(zeroStart, 1) = prevNonZeroCol1 & "|" & dataArr(zeroStart, 1)
        End If
    End If
    
    ' 将拼接结果合并到B列（和示例格式一致）
    For i = 1 To lastRow
        If resultArr(i, 1) <> "" Then
            ws.Cells(i, 2).Value = ws.Cells(i, 2).Value & " " & resultArr(i, 1)
        End If
    Next i
End Sub

代码关键说明： #

1. 数组优化：一次性读取所有数据到内存数组，处理完成后再写入单元格，避免20万行反复操作单元格的性能浪费
2. 连续0检测：遍历过程中记录连续0的起始位置和数量，精准区分「连续4个0」和「单个0」两种场景
3. 拼接逻辑对齐需求：
   • 连续4个0：仅在序列的第一个0行生成完整拼接字符串
   • 单个0：生成「前非0字段+当前字段」的拼接字符串
4. 边界处理：覆盖了第一行是0、最后一行是0的特殊情况

使用提示： #

• 如果你的数据不是从A1、B1开始，需要修改代码中Range("A1:B" & lastRow)的范围
• 20万行数据处理大概需要几秒，这是正常速度，比原公式方式快数十倍

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