请教一个组合的算法

无·法 2019-10-14 10:45:03

加精

假设有这样的一个表，两个字段，重量和数量，需要按重量50g分成一组一组的，每组N件，这个N数字没限制。比如“5 218”这组的表示5g的有218件，这样要凑成50g很简单，抽取10件即可，一共可以凑成21组还剩余8件。
但是剩下的就不好计算了，人工看的话可以把“4.9 42”和“5.1 386”这两组进行匹配，可以凑成42组，再剩下的呢？只能交给计算机随机吗？我的算法是随机抽取8件1万次，看看和是否是50g，然后随机抽取9件1万次，。。。也就是不断随机抓起一部分试验和是否符合，不过这样计算效率很低，我把剩下数据测试N从8到10，每次随机10万次，总共才匹配到300多组结果，放一部分上来：



.

.

.

5.3	5.5	5.5	5.5	5.6	5.6	5.6	5.6	5.8

5.2	5.4	5.5	5.5	5.5	5.6	5.7	5.8	5.8

5.1	5.2	5.3	5.4	5.7	5.7	5.8	5.9	5.9

5.3	5.3	5.5	5.5	5.5	5.6	5.7	5.8	5.8

5.2	5.4	5.5	5.5	5.5	5.6	5.7	5.7	5.9

5.3	5.4	5.4	5.4	5.5	5.6	5.8	5.8	5.8

5.2	5.3	5.4	5.5	5.6	5.7	5.7	5.8	5.8

5.1	5.2	5.3	5.5	5.6	5.8	5.8	5.8	5.9

3.7	3.7	5.1	5.1	5.2	5.3	5.4	5.4	5.5	5.6

3.7	3.7	5.1	5.2	5.2	5.2	5.3	5.4	5.6	5.6

3.7	3.7	5.2	5.2	5.2	5.2	5.3	5.3	5.4	5.8

3.7	3.7	5.2	5.2	5.2	5.2	5.2	5.4	5.5	5.7

3.7	3.7	5.2	5.2	5.3	5.3	5.3	5.4	5.4	5.5

3.7	3.7	5.1	5.2	5.2	5.3	5.3	5.4	5.5	5.6

3.7	3.7	5.1	5.1	5.1	5.3	5.4	5.4	5.5	5.7

3.7	3.7	5.1	5.1	5.2	5.2	5.2	5.5	5.5	5.8

.

.

.

还剩余2080件没匹配成功，这些数据每次运算不一样，通过人工计算还是有很大部分没匹配成功的。我想应该有其他更好的算法，特请教下大家。

...全文

1393 11 打赏收藏转发到动态举报

写回复

用AI写文章

11 条回复

切换为时间正序

请发表友善的回复…

发表回复

guokai1024 2020-05-15

打赏
举报

太好了啦啦啦啦邋遢

qq_46540954 2020-03-12

打赏
举报

使用C++的、string类，通过循环的方式输入5个字符串，再通过循环的方式将5个字符串按逆转后的顺序显示出来。例如，逆转前的5个字符串是：Germany Japan America Britain France 按逆转后的顺序输出字符串是 France Britain America Japan Germany谁能帮帮我呀，各位哥哥们

sinat_23993635 2020-02-19

打赏
举报

剩余2080件没匹配成功

无·法 2019-10-17

打赏
举报

楼上计算的结果已经很不错了，我后来用了个多退少补的算法，也就是随机出来的数字看看差额是否有合适的克重正好补上来，随机超出预期的就退掉，最多也就达到350多组，和你的还是差很多。

milaoshu1020 2019-10-17

打赏
举报

代码如下:



Option Explicit



Dim lngRow As Long

Const LostNumberException As Long = vbObjectError + 512



Sub 组合算法()

    Sheet2.Cells.Clear

    lngRow = 1



    Dim dctData As Object

    Set dctData = CreateObject("scripting.dictionary")

    

    With Sheet1

        Dim i As Long

        i = 2

        

        While .Cells(i, 1) <> ""

            Dim strKey As String

            strKey = .Cells(i, 1)

            

            If Not dctData.exists(strKey) Then

                dctData.Add strKey, .Cells(i, 2)

            Else

                dctData.Item(strKey) = dctData.Item(strKey) + .Cells(i, 2)

            End If

            

            i = i + 1

        Wend

    End With

    

    Debug.Print "[配前]"

    PrintStatics dctData

    SortData dctData

        

    Dim colData As Collection

    Set colData = New Collection

    

    On Error GoTo hErr

    Calc dctData, colData, 0, 1

    Debug.Print "[配后剩余]"

    PrintStatics dctData

    PrintData dctData

    MsgBox "组合完成!"

    Exit Sub

hErr:

    Select Case Err.Number

    Case LostNumberException

        For i = 1 To colData.Count

            colData.Remove 1

        Next

        SortData dctData

        Resume

    Case Else

        MsgBox Err.Number & ": " & Err.Description, vbCritical

    End Select

End Sub



Sub PrintStatics(ByVal dctData As Object)

    Dim kezhong As Double

    kezhong = 0

    

    Dim geshu As Long

    geshu = 0

    

    Dim varKey As Variant

    For Each varKey In dctData

        kezhong = kezhong + CDbl(varKey) * CDbl(dctData(varKey))

        geshu = geshu + CLng(dctData(varKey))

    Next

    

    Debug.Print "克重: " & kezhong

    Debug.Print "个数: " & geshu

End Sub



Sub SortData(ByVal dctData As Object)

    Dim dctTemp As Object

    Set dctTemp = CreateObject("scripting.dictionary")

    

    Dim varKey As Variant

    For Each varKey In dctData

        dctTemp.Item(varKey) = dctData.Item(varKey)

    Next

    dctData.RemoveAll

    

    Do

        Dim varMaxKey As Variant

        varMaxKey = Null

        

        For Each varKey In dctTemp

            If IsNull(varMaxKey) Then

                varMaxKey = varKey

            ElseIf dctTemp(varMaxKey) < dctTemp(varKey) Then

                varMaxKey = varKey

            End If

        Next

        

        dctData.Add varMaxKey, dctTemp(varMaxKey)

        dctTemp.Remove varMaxKey

        

    Loop While dctTemp.Count > 0

End Sub



Sub Calc(ByVal dctData As Variant, ByVal colData As Collection, ByVal dblSum As Double, ByVal lngLastIndex As Long)

    If Not Check(dctData, colData) Then

        Exit Sub

    End If

    

    If dblSum = 50 Then

        Do

            Dim i As Long

            For i = 1 To colData.Count

                Sheet2.Cells(lngRow, i) = colData(i)

            Next

            

            Reduce dctData, colData

            lngRow = lngRow + 1

        

        Loop While Check(dctData, colData)

        

        Dim blnZero As Boolean

        blnZero = False

        

        Dim varItem As Variant

        For Each varItem In colData

            If dctData(varItem) = 0 Then

                If dctData.exists(varItem) Then

                    dctData.Remove varItem

                    blnZero = True

                End If

            End If

        Next

        

        If blnZero Then

            Err.Raise LostNumberException

        End If

    End If

    

    i = 0

    

    Dim varKey As Variant

    For Each varKey In dctData

        i = i + 1

        

        If i >= lngLastIndex Then

            If dctData(varKey) > 0 Then

                Dim dblNewSum As Double

                dblNewSum = dblSum + varKey

                    

                If dblNewSum <= 50 Then

                    colData.Add varKey

                    Calc dctData, colData, dblNewSum, i

                    colData.Remove colData.Count

                Else

                    Static datLast As Date

                    If DateDiff("s", datLast, Now) >= 1 Then

                        datLast = Now

                        DoEvents

                    End If

                End If

            End If

        End If

    Next

End Sub



Function Check(ByVal dctData As Variant, ByVal colData As Collection) As Boolean

    Static dctTemp As Object

    If dctTemp Is Nothing Then

        Set dctTemp = CreateObject("scripting.dictionary")

    Else

        dctTemp.RemoveAll

    End If

    

    Dim varItem As Variant

    For Each varItem In colData

        If dctTemp.exists(varItem) Then

            dctTemp.Item(varItem) = dctTemp.Item(varItem) + 1

        Else

            dctTemp.Add varItem, 1

        End If

    Next

    

    Dim varKey As Variant

    For Each varKey In dctTemp

        If dctTemp(varKey) > dctData(varKey) Then

            Check = False

            Exit Function

        End If

    Next

    

    Check = True

End Function



Sub Reduce(ByVal dctData As Variant, ByVal colData As Collection)

    Dim varItem As Variant

    For Each varItem In colData

        dctData.Item(varItem) = dctData.Item(varItem) - 1

    Next

    

    DoEvents

End Sub



Sub PrintData(ByVal dctData As Object)

    Dim varKey As Variant

    For Each varKey In dctData

        Debug.Print varKey & " => " & dctData(varKey)

    Next

End Sub

下载地址:
链接：https://pan.baidu.com/s/1THhccsMo5pdPgrF0jatXog
提取码：3lcr

运行示例:

无·法 2019-10-16

打赏
举报

其中的 5 112这个人工还能配置很多，3楼应该是智能计算的吧，感觉不如纯随机来得结果有效啊

无·法 2019-10-16

打赏
举报

引用 3 楼 milaoshu1020 的回复:

如果5.2那个只算1行,479个的话,那么组合数量是252个,剩下的元素及个数是:
5.1 => 115
5.3 => 427
5.5 => 650
5.4 => 678
5.6 => 275
5 => 1
5.7 => 181

确实应该是一个5.2，不小心多复制了。我每个随机了50万次，结果如下：

已配组数：358组
配前克重：25212.5克
配前个数：4643个
配后剩余克重：7312.5克
配后剩余个数：1379个，具体为：
5.2 218
5.1 204
5.3 236
5.4 260
5.7 48
4.9 22
5.5 172
5.6 60
5 112
5.8 24
5.9 10
4.8 10
4.7 3

milaoshu1020 2019-10-16