Excel宏计算百分百占比输出错误，求代码修正或新逻辑方案

我的Excel宏运行后输出结果错误，需要修正代码逻辑。具体需求如下：

• 填充E2:I5单元格：
  • 绿色行（如第2行）公式：=D2*(100%+$A$3-$A$5)
  • 蓝色行（如第4行）公式：=D4+D3-E3
• 将所有负值替换为0
• 若H列和I列同行数值之和超过100，将其中最大值替换为100（比如H2+I2>100，就把H2和I2里大的那个改成100）

原错误代码 #

Sub ApplyFormulasWithConditions()
    Dim ws As Worksheet
    Dim i As Long, j As Long
    Dim sumPositives As Double
    Dim maxVal As Double
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your actual sheet name
    
    ' Loop through the table and apply the formulas
    For i = 2 To 5 ' Rows 2 to 5
        For j = 5 To 9 ' Columns e to i
            If j = 6 Then
                ' Formula for F2
                ws.Cells(i, j).Formula = "=$E$" & i & "*(1+$B$3-$B$5)"
            ElseIf j = 7 Then
                ' Formula for F3
                ws.Cells(i, j).Formula = "=$E$" & i & "*(1+$B$3+$B$5)"
            Else
                ' Formulas for F4 to Q5
                ws.Cells(i, j).Formula = "=$E$" & i & "+E" & i & "-F" & i & ""
            End If
            
            ' Apply condition 1: If the value is negative, make it zero
            If ws.Cells(i, j).Value < 0 Then
                ws.Cells(i, j).Value = 0
            End If
            
            ' Apply condition 2: If the value is more than 100, calculate the sum of positive values and divide by the sum
            If ws.Cells(i, j).Value > 100 Then
                sumPositives = 0
                For k = 6 To 17 ' Calculate the sum of positive values in the same row
                    If ws.Cells(i, k).Value > 0 Then
                        sumPositives = sumPositives + ws.Cells(i, k).Value
                    End If
                Next k
                If sumPositives > 0 Then
                    ws.Cells(i, j).Value = ws.Cells(i, j).Value * (sumPositives / ws.Cells(i, j).Value)
                End If
            End If
            
            ' Apply condition 3: If the maximum value in a column is greater than 100, set all values to 100 and the others to zero
            If j = 6 Then
                maxVal = Application.WorksheetFunction.Max(ws.Range(ws.Cells(2, j), ws.Cells(5, j)))
                If maxVal > 100 Then
                    For k = 2 To 5 ' Rows 2 to 5
                        ws.Cells(k, j).Value = Application.WorksheetFunction.Min(100, ws.Cells(k, j).Value)
                    Next k
                End If
            End If
        Next j
    Next i
End Sub

修正后的代码 #

Sub ApplyFormulasWithConditions_Fixed()
    Dim ws As Worksheet
    Dim i As Long, j As Long
    Dim hVal As Double, iVal As Double
    
    ' 指定工作表
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 替换为你的工作表名称
    
    ' 1. 填充E2:I5的公式
    ' 绿色行（第2行）：E2到I2批量应用公式
    For j = 5 To 9
        ws.Cells(2, j).Formula = "=D2*(1+$A$3-$A$5)"
    Next j
    
    ' 蓝色行（第4行）：E4到I4批量应用公式
    For j = 5 To 9
        ws.Cells(4, j).Formula = "=D4+D3-E3"
    Next j
    
    ' 2. 将所有负值替换为0
    For i = 2 To 5
        For j = 5 To 9
            If ws.Cells(i, j).Value < 0 Then
                ws.Cells(i, j).Value = 0
            End If
        Next j
    Next i
    
    ' 3. 检查H列和I列同行之和是否超过100，超过则将最大值设为100
    For i = 2 To 5
        hVal = ws.Cells(i, 8).Value ' H列对应第8列
        iVal = ws.Cells(i, 9).Value ' I列对应第9列
        
        If hVal + iVal > 100 Then
            If hVal >= iVal Then
                ws.Cells(i, 8).Value = 100
            Else
                ws.Cells(i, 9).Value = 100
            End If
        End If
    Next i
End Sub

修正说明 #

1. 公式逻辑对齐需求：原代码公式填充逻辑完全偏离需求，现在按要求给指定行批量填充对应公式
2. 负值处理优化：单独提取负值替换步骤，避免原代码中公式未计算完成就提前修改值的问题
3. H/I列条件实现：原代码完全未实现需求中的H/I列判断逻辑，现在重新编写对应逻辑，确保同行两列之和超100时修改最大值为100
4. 删除冗余代码：移除原代码中与需求无关的sumPositives、列最大值判断等错误逻辑

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