原出题是这样的要求：
用Excel制作了《日产量装箱小程序》，欢迎下载学习示例。
附 件:
点击下载此附件
代 码:
Sub 工人产品装盒c()
Dim ARR()
[i5:l1000].Clear
Application.DisplayAlerts = False
[I4:I1000].UnMerge
a = [a4].CurrentRegion
每盒个数 = [f5] '每盒个数N
盒号行号 = 4 '盒号行号R
' 盒号 = 1 '盒号HZH
前盒数 = 0
前余数 = 0
For I = 5 To UBound(a)
整盒数 = Int((a(I, 3) - 前余数) / 每盒个数)
余数 = (a(I, 3) - 前余数) Mod 每盒个数
规格 = a(I, 1)
度数 = a(I, 2)
标识 = a(I, 4)
If 整盒数 > 1 Then
盒子号 = 前盒数 + 1 & "-" & 前盒数 + 整盒数
BKs = BKs + 1
Cells(4 + BKs, "i") = "'" & 盒子号
Cells(4 + BKs, "j") = 规格
Cells(4 + BKs, "k") = 度数
Cells(4 + BKs, "l") = "'" & 每盒个数 & 标识 & "*" & 整盒数
前盒数 = 前盒数 + 整盒数
End If
If 整盒数 = 1 Then
盒子号 = 前盒数 + 1
BKs = BKs + 1
Cells(4 + BKs, "i") = "'" & 盒子号
Cells(4 + BKs, "j") = 规格
Cells(4 + BKs, "k") = 度数
Cells(4 + BKs, "l") = "'" & 每盒个数 & 标识 & "*" & 整盒数
前盒数 = 前盒数 + 整盒数
End If
If 余数 > 0 Then
盒子号 = 前盒数 + 1
BKs = BKs + 1
Cells(4 + BKs, "i") = "'" & 盒子号
Cells(4 + BKs, "j") = 规格
Cells(4 + BKs, "k") = 度数
Cells(4 + BKs, "l") = "'" & 余数 & 标识
前余数 = 每盒个数 - 余数
100:
If I < UBound(a) Then
If 前余数 > 0 Then
盒子号 = 盒子号
'
规格 = a(I + 1, 1)
度数 = a(I + 1, 2)
余数 = 前余数
标识 = a(I + 1, 4)
' 如果不够减怎么办？
If a(I + 1, 3) - 余数 < 0 Then
BKs = BKs + 1
Cells(4 + BKs, "i") = "'" & 盒子号
Cells(4 + BKs, "j") = 规格
Cells(4 + BKs, "k") = 度数
Cells(4 + BKs, "l") = "'" & a(I + 1, 3) & 标识
前余数 = 余数 - a(I + 1, 3)
前盒数 = 前盒数
I = I + 1
GoTo 100
Else
BKs = BKs + 1
Cells(4 + BKs, "i") = "'" & 盒子号
Cells(4 + BKs, "j") = 规格
Cells(4 + BKs, "k") = 度数
Cells(4 + BKs, "l") = "'" & 余数 & 标识
前余数 = a(I + 1, 3) - 余数
a(I + 1, 3) = 前余数
前余数 = 0
前盒数 = 前盒数 + 1
End If
End If
Else
Range("i4:l" & BKs + 4).Borders.LineStyle = xlContinuous
Range("i4:l" & BKs + 4).Interior.ColorIndex = 35
End If
Else
前余数 = 0
' 前盒数 = 前盒数 + 1
End If
Next
For u = BKs To 2 Step -1
If Cells(4 + u, "i") = Cells(3 + u, "i") Then
Range(Cells(4 + u, "i"), Cells(3 + u, "i")).Merge
End If
Next
End Sub
功能演示:
