Excel VBA实现多Gross Wage行求和后将结果粘贴至新工作表的代码问题

核心实现逻辑 #

• 完全兼容原有季度匹配逻辑：先定位Sheet1第6行中"Q1 2020"这类季度标识对应的列位置
• 自动遍历表内所有有效数据行，不管"Gross Wage"标签分散在多少行、什么位置，都能全部匹配到
• 逐个取每个"Gross Wage"行对应季度列的数值做累加，自动跳过空单元格、非数值文本，不会触发求和报错
• 直接把求和结果写入NewSheet，不用依赖剪贴板做复制粘贴，运行稳定性更高

可直接运行的完整代码 #

Sub 跨分散行汇总GrossWage()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim qtrMatch As Range, loopCell As Range
    Dim totalWage As Double
    Dim qtrCol As Long
    
    ' 绑定数据源表与结果表
    Set wsSrc = ThisWorkbook.Worksheets("Sheet1")
    Set wsDest = ThisWorkbook.Worksheets("NewSheet")
    
    ' 定位第6行的目标季度列（可根据实际需求修改匹配的季度文本）
    Set qtrMatch = wsSrc.Rows(6).Find(What:="Q1 2020", LookAt:=xlWhole, MatchCase:=False)
    If qtrMatch Is Nothing Then
        MsgBox "未匹配到目标季度标识，请检查第6行数据"
        Exit Sub
    End If
    qtrCol = qtrMatch.Column
    
    ' 遍历有效区域匹配所有"Gross Wage"标签行
    totalWage = 0
    ' 遍历范围可根据Gross Wage所在列调整，示例默认标签在A列，若为全表匹配可改为wsSrc.UsedRange.Cells
    For Each loopCell In wsSrc.UsedRange.Columns(1).Cells
        If Trim(loopCell.Value) = "Gross Wage" Then
            ' 仅累加数值型单元格，跳过空值、文本标识
            If IsNumeric(wsSrc.Cells(loopCell.Row, qtrCol).Value) Then
                totalWage = totalWage + wsSrc.Cells(loopCell.Row, qtrCol).Value
            End If
        End If
    Next loopCell
    
    ' 将求和结果写入NewSheet指定位置，可根据需求调整单元格坐标
    wsDest.Cells(10, 11).Value = totalWage
    
    ' 若需保留原有第7行数据的转置粘贴逻辑，可放开下方注释
    ' wsSrc.Range(qtrMatch.Offset(1), qtrMatch.Offset(1).End(xlToRight)).Copy
    ' wsDest.Cells(10, 11).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End Sub

适配调整提示 #

• 如果"Gross Wage"标签并非固定在A列，可将遍历范围修改为wsSrc.UsedRange.Cells，全表匹配所有位置的标签，避免漏算分散行的数值
• 代码内使用Trim()处理标签值，可兼容单元格内存在前后空格的"Gross Wage"匹配场景
• 直接单元格赋值的方式比Copy/Paste操作运行速度更快，不会出现剪贴板被占用导致的偶发报错
• 需要计算多季度汇总时，可将第6行的Find逻辑改为循环遍历所有季度列，逐列计算对应行的Gross Wage累加值

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