Excel VBA 借助if语句实现多列按条件堆叠为单列的方案求助

实现逻辑 #

• 读取Sheet1有效数据，跳过表头逐行校验规则
• 按条件匹配生成对应输出行，批量写入Sheet2提升运行效率
• 自动生成目标表表头，清空原有历史数据避免结果冲突

完整VBA代码 #

Sub StackDataToSheet2()
    Dim srcSheet As Worksheet, tgtSheet As Worksheet
    Dim lastRow As Long, i As Long, tgtRow As Long
    Dim currentType As String, xVal As Double, yVal As Double
    
    ' 绑定工作表，可按需修改表名
    Set srcSheet = ThisWorkbook.Worksheets("Sheet1")
    Set tgtSheet = ThisWorkbook.Worksheets("Sheet2")
    
    ' 初始化目标表
    tgtSheet.Cells.Clear
    tgtSheet.Range("A1:D1") = Array("Type", "ID", "数值", "来源")
    tgtRow = 2 ' 目标表起始写入行
    
    ' 获取Sheet1最后一行有效数据行号
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
    
    ' 逐行处理原始数据（跳过第1行表头）
    For i = 2 To lastRow
        currentType = srcSheet.Cells(i, "A").Value ' Type对应A列，可修改列号
        xVal = srcSheet.Cells(i, "E").Value ' X对应E列，可修改列号
        yVal = srcSheet.Cells(i, "F").Value ' Y对应F列，可修改列号
        
        ' 匹配X列规则
        If xVal <> 0 Then
            tgtSheet.Cells(tgtRow, "A").Value = currentType
            tgtSheet.Cells(tgtRow, "B").Value = srcSheet.Cells(i, "B").Value ' ID对应B列
            tgtSheet.Cells(tgtRow, "C").Value = IIf(currentType = "Pay", xVal * -1, xVal)
            tgtSheet.Cells(tgtRow, "D").Value = "X"
            tgtRow = tgtRow + 1
        End If
        
        ' 匹配Y列规则
        If yVal <> 0 Then
            tgtSheet.Cells(tgtRow, "A").Value = currentType
            tgtSheet.Cells(tgtRow, "B").Value = srcSheet.Cells(i, "B").Value
            tgtSheet.Cells(tgtRow, "C").Value = IIf(currentType = "Pay", yVal * -1, yVal)
            tgtSheet.Cells(tgtRow, "D").Value = "Y"
            tgtRow = tgtRow + 1
        End If
    Next i
    
    ' 自动调整列宽，可注释取消该功能
    tgtSheet.Columns("A:D").AutoFit
    MsgBox "处理完成，共生成" & tgtRow - 2 & "条有效记录"
End Sub

使用说明 #

• 打开目标Excel文件，按Alt+F11调出VBA编辑器
• 右键左侧工程区当前工作簿名称，选择「插入」-「模块」
• 将上述代码粘贴到模块窗口，按F5即可运行
• 若原始表列位置和默认规则不符，修改代码中对应的列号即可

效果示例 #

Sheet1原始表样例 #

Sheet2输出结果样例 #

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