编辑数字直到达到总和值

Posted 2023-02-24

【中文标题】编辑数字直到达到总和值

【英文标题】：Edit numbers until sum value has reached

【发布时间】：2021-04-30 01:49:57

【问题描述】：

我希望有一个 VBA 宏，它可以帮助我编辑每行“C”列中的值，直到达到总和值。 但是，有一些标准：

该值必须小于“B”列中的值 如果“B”列中的值为零，则“C”列中的值应为零

例如：

我在 A 列中的每一行都有特定的值，我希望 C 列的总和为 10。因此，VBA 将循环并迭代 C 列中的每一行，并检查 B 列中的数字是否大于 0，如果是，则将其加 1。遍历完每一行后，它会检查总和，如果总和没有达到一定的数量（本例为10），它会再次循环回来，每行加1，当达到总和时停止。

示例输出：

----------------------
Column B  | Column C
----------------------
  124     |     3
  100     |     3
  83      |     2
  23      |     1
  4       |     1
  0       |     0
-----------------------

代码：

Sub Loop()
Dim Report As Worksheet
Set Report = Excel.ActiveSheet

Dim cell As Range
Dim i As Integer
Dim total As Integer

total = Range("C8").Value
Range("C2:C7").ClearContents

For total = 0 To 10
 For Each cell In Range("C2:C12")
    For i = 2 To 7
        If Range("B" & i).Value > 0 Then
            cell.Value = cell.Value + 1
            If cell.Value > Range("B" & i).Value Then
                cell.Value = cell.Value
            End If
        Else:
            cell.Value = 0
        End If

        Next i
 Next cell
 total = total + Range("C8").Value

Next total

End Sub

但是，我得到的输出似乎不是我想要的输出，而是全为零。我是 VBA 的新手 :(，谁能帮我解决这个问题？

【问题讨论】：

您明白i = 2 和total = Range(...).Value 是完全多余的，因为您在For ... Loop 中使用了这两个变量，对吧？

您已经拥有For i = 2 To 7。这就是设置i 的起始值的原因。您可以放置​​ i = 4000，当它到达您的循环时，它仍会从 2 开始。

我说这是多余的（因为这两行在您的代码中绝对没有任何意义），而不是您遇到的问题。

你错过了@K.Dᴀᴠɪs 的观点。写着i = 2（或i = 4000或i = anythingelse的行可以删除，因为它什么都不做。for i = 2 to 7丢弃了之前对i的赋值，所以i = 2是一个浪费的行- 无代码，应完全删除。

Range.Offset() 属性也有助于阅读和理解 - 例如，它允许您循环遍历 C 列中的单元格并根据当前列处理其他行/列目标 C 细胞...

【参考方案1】：

以下是我对您的问题的看法，但有几件事要开始...

VBA 不太喜欢名为 loop 的 sub，因为 loop 是保留字 我在处理范围时使用了 intersect 和 offset 方法，但是有多种方法可以给这只猫剥皮 Range("C2:C7").ClearContents 将导致空单元格，而在尝试将 1 加到该值时，空单元格可能会被视为 0，但给单元格一个明确的值可能会更好，例如0 在某些情况下，例如，总共无法达到 10，如果不进行测试和处理，循环将永远运行，永远不会达到 10 我不确定 msgbox 是否适合您的任务，但无论如何我都会弹出它以防您还没有遇到它

Sub SomeLoop()
    Set totalCell = Range("C8")
    Set editableColumnRange = Range("C2:C7")
    
    'set all the editable cells to a default/initial value
    editableColumnRange.Value = 0
    
    totalAtEndOfLastLoop = 0
    total = 0
    Offset = 0
    Do While total < 10
        'set the current row to the current row offset past the top row of the editable cells
        Set currentRowRange = editableColumnRange.Rows(1).EntireRow.Offset(Offset)
        Set currentCCell = Intersect(currentRowRange, Range("C:C"))
        Set currentBCell = Intersect(currentRowRange, Range("B:B"))
        
        'implement the rules
        If currentBCell.Value = 0 Then
            currentCCell.Value = 0
        ElseIf currentBCell.Value > currentCCell.Value + 1 Then
            'to ensure b remains > c, we need to test b > c + 1
            'so if c is incremented by 1, it remains less than b
            currentCCell.Value = currentCCell.Value + 1
            total = total + 1
        End If
        
        Offset = Offset + 1
        If Offset >= editableColumnRange.Rows.Count Then
            'we've got an offset which would task us past the data
            'it's time to wrap around
            
            'check if the total has changed otherwise we'll be stuck in the loop forever
            If total > totalAtEndOfLastLoop Then
                totalAtEndOfLastLoop = total
                Offset = 0
            Else
                MsgBox "The total hasn't changed"
                Exit Do
            End If
            
        End If
    Loop
End Sub

【讨论】：

哇，谢谢！上面的解决方案在这种情况下效果很好！ :D

【参考方案2】：

小于时增加

调整常量部分和工作表（可能是工作簿）中的值。

Option Explicit

Sub doIncrement()
    
    ' Constants
    Const sFirst As String = "B2"
    Const dFirst As String = "C2"
    Const iTotal As Long = 10
    
    ' Worksheets (could be different)
    Dim sws As Worksheet: Set sws = ActiveSheet
    Dim dws As Worksheet: Set dws = ActiveSheet
    
    ' Create a reference to the Source Range.
    Dim srg As Range
    With sws.Range(sFirst)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        Set srg = .Resize(lCell.Row - .Row + 1)
    End With
    
    ' Write values from Source Range to Source Array.
    Dim rCount As Long: rCount = srg.Rows.Count
    Dim sData As Variant
    If rCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Define Destination Array.
    Dim dData() As Long: ReDim dData(1 To rCount, 1 To 1) ' Long: all zeros
    
    Dim r As Long
    Dim dTotal As Long
    
    ' Loop through rows of Source Array and write to rows of Destination Array.
    Do
        For r = 1 To rCount
            If sData(r, 1) - dData(r, 1) > 1 Then
                dData(r, 1) = dData(r, 1) + 1
                dTotal = dTotal + 1
                If dTotal = iTotal Then
                    Exit Do
                End If
            End If
        Next r
    Loop

    With dws.Range(dFirst)
        ' Write values from Destination Array to Destination Range.
        .Resize(rCount).Value = dData
        ' Clear contents below.
        .Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
            .Offset(rCount).ClearContents
    End With
    
End Sub