优化LIFO栈计算效率：用增量计算替代每日全量重复运算

问题背景 #

从指定起始日期起每日计算LIFO栈，当前代码每日全量处理历史数据，输出近70万条数据耗时10分钟；每日新增数据后需重新全量计算，效率极低。希望优化性能，或基于前一日栈结果仅处理新增数据生成新栈，同时验证“固定截至当日历史数据，取消初始循环，每日仅扩展计算范围”的思路可行性。

优化方案 #

一、全量计算性能快速优化 #

如果暂时无法切换到增量计算，可通过以下手段大幅提升全量计算速度：

• 减少工作表交互：避免逐行写入单元格，改用数组存储输出结果，最后一次性写入工作表
• 关闭Excel后台功能：宏执行期间关闭屏幕更新、事件触发、自动计算
• 避免重复初始化：复用数组空间，减少ReDim次数
• 批量读取数据：一次性将所有数据读到内存数组，避免循环中重复引用Range

修改后的全量优化核心代码：

Sub OptimizedFullCalculation()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim wsData As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long, outputRow As Long
    Dim dataArr As Variant, priceArr As Variant, dateArr As Variant
    Dim i As Long, endRow As Long
    Dim tempStackQty() As Variant, tempStackPrice() As Variant
    Dim stackCnt As Long
    Dim outputArr() As Variant
    
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
    Set wsOutput = ThisWorkbook.Worksheets("Output")
    wsOutput.UsedRange.Clear
    outputRow = 1
    lastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 批量读取所有数据到内存
    dataArr = wsData.Range("C2:C" & lastRow).Value
    priceArr = wsData.Range("B2:B" & lastRow).Value
    dateArr = wsData.Range("A2:A" & lastRow).Value
    
    ReDim tempStackQty(1 To lastRow)
    ReDim tempStackPrice(1 To lastRow)
    
    For endRow = 1 To lastRow - 1
        stackCnt = 0
        ' 重新计算到当前行的栈
        For i = 1 To endRow + 1
            If dataArr(i, 1) > 0 Then
                stackCnt = stackCnt + 1
                tempStackQty(stackCnt) = dataArr(i, 1)
                tempStackPrice(stackCnt) = priceArr(i, 1)
            Else
                While stackCnt > 0 And tempStackQty(stackCnt) + dataArr(i, 1) < 0
                    dataArr(i, 1) = dataArr(i, 1) + tempStackQty(stackCnt)
                    stackCnt = stackCnt - 1
                Wend
                If stackCnt > 0 Then tempStackQty(stackCnt) = tempStackQty(stackCnt) + dataArr(i, 1)
            End If
        Next i
        
        ' 准备输出数组
        ReDim outputArr(1 To stackCnt, 1 To 3)
        For i = 1 To stackCnt
            outputArr(i, 1) = tempStackQty(i)
            outputArr(i, 2) = tempStackPrice(i)
            outputArr(i, 3) = dateArr(endRow + 1, 1)
        Next i
        
        ' 一次性写入输出表
        wsOutput.Range("A" & outputRow).Resize(stackCnt, 3).Value = outputArr
        outputRow = outputRow + stackCnt
    Next endRow
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

二、增量计算实现（推荐方案） #

你的思路完全可行，LIFO栈的特性决定了可以基于前一日的栈状态，仅处理当日新增数据来更新栈，无需全量重算。这是解决性能问题的根本方案，核心逻辑如下：

1. 持久化栈状态：将每日计算完成后的栈数量、各层数量和价格保存到隐藏工作表，避免宏重置丢失
2. 增量读取数据：每日仅读取前一日处理截止行之后的新增数据
3. 复用栈状态：用前一日的栈作为初始状态，遍历新增数据执行LIFO入栈/出栈逻辑
4. 更新输出与状态：生成当日栈结果并输出，同时更新保存的栈状态和最后处理行号

完整增量计算代码

Option Explicit

' 全局变量存储当前栈状态（也可直接从工作表读取）
Dim currentStackQty() As Variant
Dim currentStackPrice() As Variant
Dim currentStackCount As Long
Dim lastProcessedRow As Long ' 记录最后处理的行号

' 初始化：首次运行或需要重新全量计算时调用
Sub InitializeFullStack()
    Dim wsData As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant, priceArr As Variant
    Dim i As Long
    
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
    lastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 批量读取所有历史数据
    dataArr = wsData.Range("C2:C" & lastRow).Value
    priceArr = wsData.Range("B2:B" & lastRow).Value
    
    ' 初始化栈数组
    ReDim currentStackQty(1 To lastRow)
    ReDim currentStackPrice(1 To lastRow)
    currentStackCount = 0
    
    ' 全量计算初始栈
    For i = LBound(dataArr, 1) To UBound(dataArr, 1)
        ProcessSingleTransaction dataArr(i, 1), priceArr(i, 1)
    Next i
    
    ' 记录最后处理行号并保存栈状态
    lastProcessedRow = lastRow
    wsData.Cells(1, "D").Value = lastProcessedRow ' 用D1存储最后处理行号
    SaveStackState
End Sub

' 每日增量处理：仅计算新增数据
Sub ProcessDailyNewData()
    Dim wsData As Worksheet, wsOutput As Worksheet
    Dim newStartRow As Long, newEndRow As Long
    Dim dataArr As Variant, priceArr As Variant, dateArr As Variant
    Dim i As Long
    Dim outputArr() As Variant
    Dim outputRow As Long
    
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
    Set wsOutput = ThisWorkbook.Worksheets("Output")
    
    ' 读取上次处理到的行号
    lastProcessedRow = wsData.Cells(1, "D").Value
    newStartRow = lastProcessedRow + 1
    newEndRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
    
    If newStartRow > newEndRow Then
        MsgBox "无新增数据需要处理"
        Exit Sub
    End If
    
    ' 读取当日新增交易数据
    dataArr = wsData.Range("C" & newStartRow & ":C" & newEndRow).Value
    priceArr = wsData.Range("B" & newStartRow & ":B" & newEndRow).Value
    dateArr = wsData.Range("A" & newStartRow & ":A" & newEndRow).Value
    
    ' 基于现有栈处理新增数据
    For i = LBound(dataArr, 1) To UBound(dataArr, 1)
        ProcessSingleTransaction dataArr(i, 1), priceArr(i, 1)
    Next i
    
    ' 准备当日栈结果输出数组
    outputRow = wsOutput.Cells(Rows.Count, 1).End(xlUp).Row + 1
    ReDim outputArr(1 To currentStackCount, 1 To 3)
    
    For i = 1 To currentStackCount
        outputArr(i, 1) = currentStackQty(i)
        outputArr(i, 2) = currentStackPrice(i)
        outputArr(i, 3) = dateArr(UBound(dateArr, 1), 1) ' 当日日期
    Next i
    
    ' 一次性写入输出表，大幅提升速度
    wsOutput.Range("A" & outputRow).Resize(currentStackCount, 3).Value = outputArr
    
    ' 更新最后处理行号并保存栈状态
    lastProcessedRow = newEndRow
    wsData.Cells(1, "D").Value = lastProcessedRow
    SaveStackState
End Sub

' 单个交易数据的LIFO处理逻辑
Sub ProcessSingleTransaction(dataVal As Variant, priceVal As Variant)
    If dataVal > 0 Then
        ' 正数入栈
        currentStackCount = currentStackCount + 1
        currentStackQty(currentStackCount) = dataVal
        currentStackPrice(currentStackCount) = priceVal
    Else
        ' 负数出栈，按LIFO规则抵消
        While currentStackCount > 0 And currentStackQty(currentStackCount) + dataVal < 0
            dataVal = dataVal + currentStackQty(currentStackCount)
            currentStackCount = currentStackCount - 1
        Wend
        
        If currentStackCount > 0 Then
            ' 剩余部分抵消栈顶元素
            currentStackQty(currentStackCount) = currentStackQty(currentStackCount) + dataVal
        End If
    End If
End Sub

' 保存栈状态到隐藏工作表，防止宏重置丢失
Sub SaveStackState()
    Dim wsState As Worksheet
    On Error Resume Next
    Set wsState = ThisWorkbook.Worksheets("StackState")
    On Error GoTo 0
    
    ' 若不存在则创建隐藏工作表
    If wsState Is Nothing Then
        Set wsState = ThisWorkbook.Worksheets.Add
        wsState.Name = "StackState"
        wsState.Visible = xlSheetHidden
    End If
    
    wsState.UsedRange.Clear
    If currentStackCount > 0 Then
        ' 转置数组写入工作表
        wsState.Range("A1:A" & currentStackCount).Value = Application.Transpose(currentStackQty)
        wsState.Range("B1:B" & currentStackCount).Value = Application.Transpose(currentStackPrice)
    End If
    wsState.Cells(1, "C").Value = currentStackCount ' 保存栈元素数量
End Sub

' 加载保存的栈状态，宏启动时自动执行
Sub LoadStackState()
    Dim wsState As Worksheet
    On Error Resume Next
    Set wsState = ThisWorkbook.Worksheets("StackState")
    On Error GoTo 0
    
    If wsState Is Nothing Then Exit Sub
    
    ' 读取栈状态
    currentStackCount = wsState.Cells(1, "C").Value
    If currentStackCount > 0 Then
        ReDim currentStackQty(1 To currentStackCount)
        ReDim currentStackPrice(1 To currentStackCount)
        currentStackQty = Application.Transpose(wsState.Range("A1:A" & currentStackCount).Value)
        currentStackPrice = Application.Transpose(wsState.Range("B1:B" & currentStackCount).Value)
    End If
    
    ' 读取最后处理行号
    lastProcessedRow = ThisWorkbook.Worksheets("Sheet1").Cells(1, "D").Value
End Sub

' 宏启动时自动加载栈状态
Sub Auto_Open()
    LoadStackState
End Sub

方案优势

• 性能飞跃：每日仅处理新增数据，处理时间从10分钟缩短至秒级（取决于当日新增数据量）
• 状态持久化：即使关闭Excel再打开，也能从上次中断的位置继续计算
• 逻辑兼容：完全保留原LIFO计算逻辑，确保结果正确性

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