excel 将列表中的值求和到一定的数量，并创建最少数量的“集合”

xuo3flqw 于 2023-05-01 发布在其他

关注(0)|答案(2)|浏览(113)

我有一个列表，其中的值大小可变，各个值的范围从1到33。（这是基于卡车中的托盘数量。）
我想选择该范围，并让VBA代码决定将值相加为33（永远不会超过33）的最佳方法，并使用这些值创建一个数组，然后移动到下一个“集合”，并将下一个添加到33的值放入新数组中。我知道如何长期地做（感谢Stack Overflow用户），但这不是最有效的选择。
假设我有一个包含5个值的列表：
10
15
8
22
19
这将创建3个“集”：
25
30
19
如果5个值的顺序更改为：
19
22
15
10
8
这将创建4个“集”：
19
22
15
18
我找到了一种方法来定义代码应该创建的卡车的最佳数量的变量，但是对于第二个列表，如果代码长期遍历该列表，则会导致错误。
有没有可能创建一个代码，它会查看一组值，并决定最有效的组合最接近33的值的方法。

Sub test()
Dim ref, b As Range
Dim volume, i As Integer
Dim test1(), check, total As Double
Dim c As Long

Set ref = Selection
volume = ref.Cells.Count
c = ref.Column
ReDim test1(1 To volume)

'this creates a total of all the values i select
For Each b In ref
    total = total + b
Next b

'this determines when to round up or down
check = total / 33 - Application.WorksheetFunction.RoundDown(total / 33, 0)
If check < 0.6 Then
    total = Application.WorksheetFunction.RoundDown(total / 33, 0)
Else
    total = Application.WorksheetFunction.RoundUp(total / 33, 0)
End If

'this creates an array with all the values
i = 1
Do Until i = volume + 1
    test1(i) = Cells(i, c).Value
    i = i + 1
Loop

'this is just a way for me to check and verify my current part of the code
MsgBox (Round(test1(8), 2))
MsgBox (total)

End Sub

excel

来源：https://stackoverflow.com/questions/74199567/sum-list-of-values-to-a-certain-number-and-create-the-least-number-of-sets

2条答案

按热度按时间

moiiocjp1#

您可以根据自己的意愿更改单元格结果位置。我在即时窗口中显示结果。

Sub test()
Dim CellsCount As Integer

CellsCount = Selection.Cells.Count

Dim i, j As Long
Dim x, y As Long
Dim SumLoop As Long
SumLoop = 0
x = 1
y = 1

For i = x To CellsCount
    Do
        For j = y To CellsCount
            SumLoop = SumLoop + Selection.Cells(j).Value
            If SumLoop < 33 Then
                Debug.Print SumLoop
                y = j + 1
                If y = CellsCount + 1 Then Exit Sub
            Else
                
                SumLoop = 0
                x = j
                y = j
                Exit For
            End If
        Next
    Loop While SumLoop < 33
Next

End Sub

赞(0）回复(0）举报 2023-05-01

ifsvaxew2#

这是一个直接的蛮力，检查每一个组合，如果你的集合变得太大，这将慢下来，但它是〈1秒的一组1000。
我把数值输入A列。输出您所需的最低数量的卡车。
你可能可以通过使用类型或类来减少变量的数量，但希望保持相对简单。

Dim i As Long
    Dim lr As Long
    Dim limit As Long
    Dim count As Long
    Dim sets As Long
    Dim best As Long
    Dim start As Long
    Dim addset As Boolean
    Dim loopcounter As Long
    
    limit = 33
    
    With Sheets("Sheet1")
        lr = .Cells(.Rows.count, 1).End(xlUp).Row
        Dim arr() As Long
        ReDim arr(0 To lr - 2)
        For i = 2 To lr
            arr(i - 2) = .Cells(i, 1).Value 'Load array
        Next i
        
        start = 0
        i = start
        Do
            If count + arr(i) <= limit Then
                count = count + arr(i)
                addset = False 'Just for tracking the final set
            Else
                addset = True
                sets = sets + 1
                count = arr(i)
            End If
            i = i + 1
            If i > UBound(arr) Then
                i = 0 'reset index
            End If
            loopcounter = loopcounter + 1 'tracking items in set
            If loopcounter > UBound(arr) Then
                If addset = False Then
                    sets = sets + 1 'adding final set if not already added
                End If
                Debug.Print start, sets
                If best > sets Or best = 0 Then
                    best = sets 'Get the lowest value
                End If
                'resetting values
                loopcounter = 0
                sets = 0
                start = start + 1
                i = start
                If start > UBound(arr) Then
                    Exit Do
                End If
            End If
        Loop
    End With
    Debug.Print best

赞(0）回复(0）举报 2023-05-01

我来回答

excel 将列表中的值求和到一定的数量，并创建最少数量的“集合”

2条答案

相关问题

热门标签

最新问答