产品零件规划入箱问题，大神帮看下vba需要如何修改？

韵雪中庸 · 发表于 2024-1-3 08:54

本帖最后由韵雪中庸于 2024-1-4 13:08 编辑

vba代码：
结果：在G列给出箱序，从1开始编号，一直编完，例如A1单位2箱，则如G3-G9,
约束条件：
1、单位之间不能混箱，每个单位都从第一箱开始编；
2、排在前面的零件尽量装在前面的箱子；
3、每个箱子所装零件不能超过30单位体积，即每一箱的E列求和小于等于30；

4、每个单位的箱子数用两最少；
5、每个单位的同种零件只能装同一个箱子。

代码：

Sub GenerateBoxSequence()
Dim ws As Worksheet
Dim lastRow As Long
Dim boxCount As Long
Dim currentBox As Long
Dim currentVolume As Double
Dim currentRow As Long
' 设置工作表
Set ws = ThisWorkbook.Worksheets("Sheet1")
' 获取最后一行
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
' 初始化变量
boxCount = 0
currentBox = 1
currentVolume = 0
' 遍历每一行
For currentRow = 2 To lastRow
' 获取当前行的考点名称和占用体积
Dim pointName As String
Dim volume As Double
pointName = ws.Cells(currentRow, "B").Value
volume = ws.Cells(currentRow, "E").Value
' 判断是否需要新的箱子
If currentVolume + volume > 30 Then
currentBox = currentBox + 1
currentVolume = volume
Else
currentVolume = currentVolume + volume
End If
' 将箱序序号写入G列
ws.Cells(currentRow, "G").Value = currentBox
Next currentRow
End Sub

复制代码

排箱序vba求解.zip (19.39 KB, 下载次数: 12)

titi012 · 发表于 2024-1-3 14:46

Sub tt()
Dim Arr, Drr, Brr() As Integer, x&, y&, i&, N&, H&, d As Object
Set d = CreateObject("scripting.dictionary")
Arr = Range("b3:e" & Cells(Rows.Count, 2).End(xlUp).Row).Value
ReDim Brr(1 To UBound(Arr))
For x = 1 To UBound(Arr)
d(Arr(x, 1)) = ""
Next x
Drr = d.keys
For i = 0 To UBound(Drr)
N = 0: H = 1
For x = 1 To UBound(Arr)
If Arr(x, 1) = Drr(i) And Brr(x) = 0 Then
If N + Arr(x, 4) <= 30 Then
Brr(x) = H: N = N + Arr(x, 4)
Else
For y = x + 1 To UBound(Arr)
If N + Arr(y, 4) <= 30 Then Brr(y) = H: N = N + Arr(y, 4)
Next y
H = H + 1: N = 0
Brr(x) = H: N = N + Arr(x, 4)
End If
End If
Next x, i
Range("g3").Resize(UBound(Arr), 1) = WorksheetFunction.Transpose(Brr)
End Sub

复制代码

韵雪中庸 · 发表于 2024-1-4 09:29

titi012 发表于 2024-1-3 14:46

首先谢谢大神，试跑了一下，成功率为75%，是不是因为单位名称那里获取的字符不够多的问题？，从而导致会误认为是一个单位，如何提高准确度？
偶尔会多一箱出来

屏幕截图 2024-01-04 081949.png

titi012 · 发表于 2024-1-4 09:56

韵雪中庸发表于 2024-1-4 09:29
首先谢谢大神，试跑了一下，成功率为75%，是不是因为单位名称那里获取的字符不够多的问题？，从而导致会 ...

算法的问题。我的算法是不对的，随便写一下的，没有规划求解的
如果要按你的要求，尽量减少箱数，还要重新想想

fjlhgs · 发表于 2024-1-4 10:07

参与一下。。。

韵雪中庸 · 发表于 2024-1-4 11:52

fjlhgs 发表于 2024-1-4 10:07
参与一下。。。

谢谢你，还是有多出一箱的问题存在。
比如A9单位，
第7箱的S零件和N零件可以分到第1箱，
第7箱的M零件可以分到第4箱，
从而6箱可以装完。
屏幕截图 2024-01-04 114858.png

韵雪中庸 · 发表于 2024-1-4 12:27

titi012 发表于 2024-1-4 09:56
算法的问题。我的算法是不对的，随便写一下的，没有规划求解的
如果要按你的要求，尽量减少箱数，还要重 ...

嗯，谢谢你，希望能看到一个更完善的方案

fjlhgs · 发表于 2024-1-4 15:29

漏了一个EXIT FOR

Sub P()
Dim i As Long, j As Long, k As Long, d As Object, d1 As Object, n As Long, v As Double, x, a As Double
Sheets("装箱").Activate
a = Cells(1, 8)
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
i = 3
Do Until Cells(i, 2) = ""
      s = Cells(i, 2)
      k = 0
      k = d(s)
      If k = 0 Then
         d(s) = 1
         k = 1
         d1(s & "$1") = a
      End If
      v = Cells(i, 5)
      For j = 1 To k
         x = d1(s & "$" & j)
         If x <> "" Then
            If v < x Then
                  Cells(i, 7) = j
                  d1(s & "$" & j) = d1(s & "$" & j) - v
                  Exit For
            ElseIf v = x Then
                  Cells(i, 7) = j
                  d1(s & "$" & j) = ""
                  Exit For
            End If
         End If
      Next
      If j = k + 1 Then
         d(s) = j
         Cells(i, 7) = j
         d1(s & "$" & j) = a - v
      End If
      i = i + 1
Loop
End Sub

韵雪中庸 · 发表于 2024-1-4 19:38

fjlhgs 发表于 2024-1-4 15:29
漏了一个EXIT FOR

Sub P()

可以了，接近完美，还可以实时调整箱子大小（最多装入量），神补啊

EHGOOD · 发表于 2024-1-5 09:47

参与一下。

		自动登录	找回密码
密码			免费注册

[求助] 产品零件规划入箱问题，大神帮看下vba需要如何修改？

评分

评分

评分