使用一维装箱算法优化工作分配_4.附件
本文源码基于第一版装箱工具。请参考功能改进后的最新版本。
一维装箱工具近期变化(截至 2021 年 3 月 21 日)
五、附录
5.1.基于Excel VBA的工具源码
用Excel VBA实现的装箱是纯VBA代码实现的,没有外部库和包,所以源代码量比较长。大部分算法都是在CPacker类中实现的,所以先看看这个类。
5.1.1.运行表源代码
这段代码对应“Run BinPacking”按钮的点击事件。
使用 Excel 的 Range 对象,将列表的基本范围和选项值传递给 RunBinPacking 过程。在这里,Range 主要使用由名称定义的实体。 (例子:Range(“MaxBinSize”))如果Range被定义为一个名称,即使参考地址改变也不需要改变源代码,而且很方便,因为参考地址在函数时自动改变,例如执行行插入和列插入。。
Private Sub cmdRunBinPacking_Click()
RunBinPacking aBaseRange:=Range("B2").Address, _
aMaxBinSize:=Range("MaxBinSize").Value, _
aSizeBaseColumn:=Range("SizeBaseClolumn").Value, _
aIsItemSort:=Range("ItemSize내림차순정렬여부").Value
End Sub
5.1.2. modFactory模块源代码
负责创建类的实例。不能在 VBA 类中使用参数覆盖构造函数。使用通过工厂模式而不是构造函数实现的模块。
CreatePacker过程中的aPackingType是一个枚举变量,表示Bin Packing算法处理类型。有四个可能的值:ptNextFit、ptFirstFit、ptBestFit 和 ptWorstFit。
Option Explicit
Public Function CreatePacker(aMaxBinSize As Long, aPackingType As PackingType) As CPacker
Set CreatePacker = New CPacker
CreatePacker.Init aMaxBinSize, aPackingType
End Function
Public Function CreateBin(aMaxBinSize As Long) As CBin
Set CreateBin = New CBin
CreateBin.Init aMaxBinSize
End Function
5.1.3. modControl模块源码
它负责管理RunBinPacking过程中的整个算法处理过程。各参数含义如下。
- aBaseRange:输入数据的起始范围(字符串如“B2”)
- aMaxBinSize:限制一个bin的最大尺寸(整数如80、10000等)
- aSizeBaseColumn:选项中选择的Bin size base column name(字符串如“C”)
- aIsItemSort:是否执行降序排序(True/False值)
Option Explicit
Public Sub RunBinPacking(aBaseRange As String, aMaxBinSize As Long, _
aSizeBaseColumn As String, aIsItemSort As Boolean)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim oBaseRange As Range, lCurRow As Long, oBinItem As CBinItem
Dim oInputItemCol As CBinItemCollection: Set oInputItemCol = New CBinItemCollection
Set oBaseRange = Range(aBaseRange)
Dim sSizeBaseColumn As String, lSizeColumnOffset As Long
sSizeBaseColumn = aSizeBaseColumn 'Range("SizeBaseClolumn")
lSizeColumnOffset = Range(oBaseRange, sSizeBaseColumn & "2").Columns.Count - 1
'Build up the BinItem List Collection
lCurRow = 0
For lCurRow = 0 To oBaseRange.CurrentRegion.Rows.Count
If Trim(oBaseRange.Offset(lCurRow, 0).Value) = "" Then Exit For
Set oBinItem = New CBinItem
oBinItem.m_sName = oBaseRange.Offset(lCurRow, 0).Value 'Item Name
oBinItem.m_lSize = oBaseRange.Offset(lCurRow, lSizeColumnOffset).Value 'Item Size 기준 컬럼의 값(예: KB, MB 등)
oInputItemCol.Add oBinItem, oBinItem.m_sName
Next lCurRow
'Item Size로 내림차순 정렬 처리
If aIsItemSort Then
DoLog "정렬 전 --> " + oInputItemCol.GetString
Set oInputItemCol = oInputItemCol.Sort
DoLog "정렬 후 --> " + oInputItemCol.GetString
End If
Dim lMaxBinSize As Long
Dim oPackerNextFit As CPacker, oPackerFirstFit As CPacker
Dim oPackerWorstFit As CPacker, oPackerBestFit As CPacker
lMaxBinSize = aMaxBinSize
'NextFit
Set oPackerNextFit = CreatePacker(lMaxBinSize, ptNextFit)
oPackerNextFit.DoPacking oInputItemCol
oPackerNextFit.DoOutput Worksheets("Next Fit")
Set oPackerNextFit = Nothing
'FirstFit
Set oPackerFirstFit = CreatePacker(lMaxBinSize, ptFirstFit)
oPackerFirstFit.DoPacking oInputItemCol
oPackerFirstFit.DoOutput Worksheets("First Fit")
Set oPackerFirstFit = Nothing
'WorstFit
Set oPackerWorstFit = CreatePacker(lMaxBinSize, ptWorstFit)
oPackerWorstFit.DoPacking oInputItemCol
oPackerWorstFit.DoOutput Worksheets("Worst Fit")
Set oPackerWorstFit = Nothing
'BestFit
Set oPackerBestFit = CreatePacker(lMaxBinSize, ptBestFit)
oPackerBestFit.DoPacking oInputItemCol
oPackerBestFit.DoOutput Worksheets("Best Fit")
Set oPackerBestFit = Nothing
Worksheets("Result Summary").Activate
Worksheets("Result Summary").Range("E1") = lMaxBinSize
DoEvents
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
5.1.4. modUtil模块源码
它负责常见的功能,例如记录和将所需时间转换为字符串格式。日志记录使用 Windows API OutputDebugString。
Option Explicit
#Const DEBUGMODE = 1
#If VBA7 Then 'For 64 Bit Systems
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Private Declare PtrSafe Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)
#Else 'For 32 Bit Systems
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)
#End If
'OutputDebugString API를 이용한 Debug Message 출력
'DebugView등을 이용하여 메시지 View 가능함
Public Sub DoLog(aMsg As String)
#If DEBUGMODE >= 1 Then
OutputDebugString "[Bin] " & aMsg
#End If
End Sub
Function GetTimeString(dTime As Double) As String
Dim H As Integer, M As Integer, S As Integer, MS As Integer, dMS As Double, sMS As String
H = Int(dTime / 3600)
M = Int(dTime / 60) Mod 60
S = Int(dTime Mod 60)
dMS = (dTime - Int(dTime))
'MS = dMS * 10 ^ (Len(CStr(dMS)) - 2)
sMS = Mid(CStr(dMS), 3, Len(dMS))
GetTimeString = Format(H, "00") & ":" & Format(M, "00") & ":" & Format(S, "00") & "." & sMS
End Function
5.1.5. CPacker类源码
实施装箱算法,将输入数据填充到现有箱列表中的适当位置,或创建并填充新箱。主要变量、过程和函数如下。
- Bin 对象的列表作为 m_oBinCol 集合变量进行管理,每个 Bin 对象的剩余空间的总和作为 lRemainSizeSum 变量进行管理。
- Init 过程:设置 bin 的最大尺寸和填充算法的类型(Next Fit、First Fit、Best Fit、Worst Fit)。
添加过程:将作为参数传递的 Bin 对象添加到 m_oBinCol 集合变量并创建名称“Bin_order number 5”。 - DoPacking 过程:将作为参数传递的项目列表填充到 Bin 对象列表中。
- GetNewBin 函数:使用 modFactory 模块的 CreateBin 函数创建一个新的 Bin 对象。
- GetBinNextFit 函数:选择或创建一个合适的 bin 来填充作为参数传递的 BinItem,使用 Next Fit 算法并返回。
- GetBinFirstFit 函数:选择合适的 bin 以使用 First Fit 算法填充作为参数接收的 BinItem,或者创建一个新的 bin 并将其返回。
- GetBinWorstFit 函数:选择或创建一个合适的 bin 以使用最差拟合算法填充作为参数接收的 BinItem 并返回它。
- GetBinBestFit 函数:选择或创建合适的 bin 以使用最佳拟合算法填充作为参数接收的 BinItem 并返回它。
- PackToBin 过程:根据您设置的算法类型调用适当的函数来填充 BinItem。
- DoOutput过程:将装箱处理结果输出到指定的sheet。
Option Explicit
Public m_oBinCol As Collection
Public m_dElapsedTime As Double
Public Enum PackingType
ptNextFit
ptFirstFit
ptBestFit
ptWorstFit
End Enum
Private m_lMaxBinSize As Long
Private m_lLastBinIndex As Long
Private m_PackingType As PackingType
Private m_lCompareCount As Long '비교연산의 횟수 누적
Private m_lRemainSizeSum As Long '잔여공간 합계
Private m_oTimer As CTimer
Private Sub Class_Initialize()
Set m_oBinCol = New Collection
Set m_oTimer = New CTimer
m_lLastBinIndex = 1
m_lCompareCount = 0
End Sub
Private Sub Class_Terminate()
Set m_oBinCol = Nothing
Set m_oTimer = Nothing
End Sub
Public Sub Init(aMaxBinSize As Long, aPackingType As PackingType)
m_lMaxBinSize = aMaxBinSize
m_PackingType = aPackingType
End Sub
'입력자료 목록을 입력으로 전체 채우기 실행
Public Sub DoPacking(aInputItemCol As CBinItemCollection)
Dim oBinItem As CBinItem
m_oTimer.StartCounter
For Each oBinItem In aInputItemCol.m_oBinItemCol
Me.PackToBin oBinItem
Next
Me.m_dElapsedTime = m_oTimer.TimeElapsed
End Sub
'한 Item 채우기
Public Sub PackToBin(oBinItem As CBinItem)
Dim oBin As CBin
'Select Case ePackingType
Select Case m_PackingType
Case ptNextFit
Set oBin = GetBinNextFit(oBinItem)
Case ptFirstFit
Set oBin = GetBinFirstFit(oBinItem)
Case ptWorstFit
Set oBin = GetBinWorstFit(oBinItem)
Case ptBestFit
Set oBin = GetBinBestFit(oBinItem)
End Select
oBin.AddBinItem oBinItem
End Sub
Public Sub Add(oBin As CBin)
m_oBinCol.Add oBin
oBin.m_lIndex = m_oBinCol.Count
'oBin.m_sName = "Bin" + CStr(m_oBinCol.Count)
oBin.m_sName = "Bin_" + Format(CStr(m_oBinCol.Count), "00000")
End Sub
Public Function GetNewBin() As CBin
Dim oBin As CBin
'Set oBin = New CBin
Set oBin = CreateBin(m_lMaxBinSize)
Me.Add oBin
Set GetNewBin = oBin
End Function
'NextFit
Public Function GetBinNextFit(oBinItem As CBinItem) As CBin
Dim oBin As CBin, oResult As CBin
If m_oBinCol.Count = 0 Then
'첫번째 실행인 경우
Set oResult = GetNewBin
m_lLastBinIndex = 1
Else
Set oBin = m_oBinCol(m_lLastBinIndex)
m_lCompareCount = m_lCompareCount + 1
If oBin.IsAbleToAdd(oBinItem) Then
Set oResult = oBin
Else
Set oResult = GetNewBin
m_lLastBinIndex = oResult.m_lIndex
End If
End If
Set GetBinNextFit = oResult
End Function
'FirstFit
Public Function GetBinFirstFit(oBinItem As CBinItem) As CBin
Dim oBin As CBin, bFound As Boolean, lCurBinIndex As Long, oResult As CBin
bFound = False
'항상 처음 Bin부터 확인하여 추가할 수 있는 Bin return
For lCurBinIndex = 1 To m_oBinCol.Count
'For Each oBin In m_oBinCol
Set oBin = m_oBinCol(lCurBinIndex)
m_lCompareCount = m_lCompareCount + 1
If oBin.IsAbleToAdd(oBinItem) Then
bFound = True
Set oResult = oBin
Exit For
End If
Next
If Not bFound Then
Set oResult = GetNewBin
End If
Set GetBinFirstFit = oResult
End Function
'WorstFit
Public Function GetBinWorstFit(oBinItem As CBinItem) As CBin
Dim oBin As CBin, bFound As Boolean, lCurBinIndex As Long, oResult As CBin
Dim lMaxRemainSize As Long, lMaxRemainSizeBinIndex As Long
lMaxRemainSize = 0: lMaxRemainSizeBinIndex = 0
'모든 Bin중에서 남은 Size가 가장 크고 oBinItem을 추가할 수 있는 Bin을 return
'추가할 수 있는 Bin이 없으면 새 Bin을 생성
For lCurBinIndex = 1 To m_oBinCol.Count
'남은 Size가 가장 큰 Bin 찾기
Set oBin = m_oBinCol(lCurBinIndex)
m_lCompareCount = m_lCompareCount + 1
If lMaxRemainSize < oBin.m_lRemainSize Then
lMaxRemainSize = oBin.m_lRemainSize
lMaxRemainSizeBinIndex = lCurBinIndex
End If
Next
bFound = False
m_lCompareCount = m_lCompareCount + 1
If lMaxRemainSizeBinIndex > 0 Then
Set oBin = m_oBinCol(lMaxRemainSizeBinIndex)
If oBinItem.m_lSize <= oBin.m_lRemainSize Then
bFound = True
Set oResult = oBin
End If
End If
If Not bFound Then
Set oResult = GetNewBin
End If
Set GetBinWorstFit = oResult
End Function
'BestFit
Public Function GetBinBestFit(oBinItem As CBinItem) As CBin
Dim oBin As CBin, bFound As Boolean, lCurBinIndex As Long, oResult As CBin
Dim lMinRemainSize As Long, lMinRemainSizeBinIndex As Long
lMinRemainSize = m_lMaxBinSize
lMinRemainSizeBinIndex = 0
'모든 Bin중에서 남은 Size가 가장 적으면서 oBinItem을 추가할 수 있는 Bin을 return
'추가할 수 있는 Bin이 없으면 새 Bin을 생성
For lCurBinIndex = 1 To m_oBinCol.Count
'oBinItem을 추가할 수 있는 Bin중 남은 Size가 가장 작은 Bin 찾기
Set oBin = m_oBinCol(lCurBinIndex)
m_lCompareCount = m_lCompareCount + 1
If oBin.m_lRemainSize >= oBinItem.m_lSize And _
lMinRemainSize > oBin.m_lRemainSize Then
lMinRemainSize = oBin.m_lRemainSize
lMinRemainSizeBinIndex = lCurBinIndex
End If
Next
bFound = False
m_lCompareCount = m_lCompareCount + 1
If lMinRemainSizeBinIndex > 0 Then
Set oBin = m_oBinCol(lMinRemainSizeBinIndex)
bFound = True
Set oResult = oBin
End If
If Not bFound Then
Set oResult = GetNewBin
End If
Set GetBinBestFit = oResult
End Function
'결과 출력
Public Sub DoOutput(oResultSht As Worksheet)
oResultSht.Activate
Dim oResultBaseRange As Range, oBin As CBin, lCurRow As Long, oBinItem As CBinItem
Set oResultBaseRange = oResultSht.Range("A2")
'oResultBaseRange.End(xlDown).Resize(0, 2).Clear
oResultBaseRange.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Resize(, 3).Select
'Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
oResultBaseRange.Select
lCurRow = 0
oResultSht.Range("I1") = m_dElapsedTime '소요시간
oResultSht.Range("J1").NumberFormatLocal = "@"
oResultSht.Range("J1") = GetTimeString(m_dElapsedTime)
oResultSht.Range("I2") = m_lCompareCount '비교횟수
oResultSht.Range("I3") = GetRemainSizeSum '잔여공간합계
oResultSht.Range("I4") = Me.m_oBinCol.Count * m_lMaxBinSize '전체공간합계
For Each oBin In Me.m_oBinCol
For Each oBinItem In oBin.m_oBinItemCol.m_oBinItemCol
oResultBaseRange.Offset(lCurRow, 0) = oBin.m_sName
oResultBaseRange.Offset(lCurRow, 1) = oBinItem.m_sName
oResultBaseRange.Offset(lCurRow, 2) = oBinItem.m_lSize
lCurRow = lCurRow + 1
Next
Next
Dim pt As PivotTable, sDataRange As String
sDataRange = oResultSht.Name + "!R1C1:R" + CStr(oResultBaseRange.CurrentRegion.Rows.Count) + _
"C" + CStr(oResultBaseRange.CurrentRegion.Columns.Count)
For Each pt In oResultSht.PivotTables
pt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=sDataRange, Version:=xlPivotTableVersion14)
pt.RefreshTable
Next
oResultBaseRange.Select
End Sub
'잔여공간 합계 계산후 return
Public Function GetRemainSizeSum() As Long
m_lRemainSizeSum = 0
Dim oBin As CBin
For Each oBin In Me.m_oBinCol
m_lRemainSizeSum = m_lRemainSizeSum + oBin.m_lRemainSize
Next
GetRemainSizeSum = m_lRemainSizeSum
End Function
5.1.6. CBin类源码
实施个人垃圾箱。
- 使用 m_oBinItemCol 集合变量管理填充在 bin 中的项目。
- Init程序:设置最大bin大小。
- AddBinItem 过程:在填充当前 bin 的意义上将项目添加到 m_oBinItemCol 集合。此时将对应item的大小加上当前bin的大小作为m_lCurSize变量进行管理,将bin的最大大小减去当前bin的大小后的剩余大小作为变量进行管理m_lRemainSize。
- IsAbleToAdd:判断作为参数接收到的BinItem是否可以填充到当前Bin中。如果将项目的大小添加到当前 bin 的大小的结果小于或等于最大大小,则为真。
Option Explicit
Public m_oBinItemCol As CBinItemCollection
Public m_lIndex As Long
Public m_sName As String
Public m_lCurSize As Long
Public m_lMaxSize As Long
Public m_lRemainSize As Long
Private Sub Class_Initialize()
Set m_oBinItemCol = New CBinItemCollection
m_lCurSize = 0
End Sub
Private Sub Class_Terminate()
Set m_oBinItemCol = Nothing
End Sub
Public Sub Init(lMaxBinSize As Long)
m_lMaxSize = lMaxBinSize
End Sub
Public Sub AddBinItem(oBinItem As CBinItem)
m_oBinItemCol.Add oBinItem, oBinItem.m_sName
m_lCurSize = m_lCurSize + oBinItem.m_lSize
m_lRemainSize = m_lMaxSize - m_lCurSize
If m_lRemainSize < 0 Then m_lRemainSize = 0
End Sub
Public Function IsAbleToAdd(oBinItem As CBinItem) As Boolean
IsAbleToAdd = m_lCurSize + oBinItem.m_lSize <= m_lMaxSize
End Function
5.1.7. CBinItemCollection类源代码
实现 BinItems 列表。
- BinItems 列表由 m_oBinItemCol 集合变量管理。
- 添加过程:将作为参数接收的项目添加到 m_oBinItemCol 集合。
- 排序函数:返回一个新集合,该集合按每个项目大小的降序对 m_oBinItemCol 集合进行排序。
- GetString 函数: 以 [name: size] 格式的字符串形式返回整个项目。
Option Explicit
Public m_oBinItemCol As Collection
Private Sub Class_Initialize()
Set m_oBinItemCol = New Collection
End Sub
Private Sub Class_Terminate()
Set m_oBinItemCol = Nothing
End Sub
Public Sub Add(aBinItem As CBinItem, Optional aKey As String = "")
m_oBinItemCol.Add aBinItem, IIf(aKey = "", aBinItem.m_sName, aKey)
End Sub
'BinItem의 Size로 내림차순 정렬
Public Function Sort() As CBinItemCollection
Dim i As Long, j As Long, k As Long, bln As Boolean
Dim lngCount As Long, arr() As Long, oSortedBinItemCol As CBinItemCollection
lngCount = m_oBinItemCol.Count
If lngCount > 0 Then
ReDim arr(0 To lngCount - 1)
For i = 0 To lngCount - 1: arr(i) = i + 1: Next
For i = 1 To lngCount - 1
k = arr(i)
j = i - 1
bln = False
Do
If m_oBinItemCol(arr(j)).CompareTo(m_oBinItemCol(k)) > 0 Then
arr(j + 1) = arr(j)
j = j - 1
If j < 0 Then bln = True
Else
bln = True
End If
Loop Until bln
arr(j + 1) = k
Next
End If
Set oSortedBinItemCol = New CBinItemCollection
For i = lngCount - 1 To 0 Step -1: oSortedBinItemCol.Add m_oBinItemCol(arr(i)): Next
Set Sort = oSortedBinItemCol
End Function
'BinItem 목록을 문자열로 반환
Public Function GetString() As String
Dim sResult As String, oBinItem As CBinItem
For Each oBinItem In m_oBinItemCol
sResult = sResult + "[" + oBinItem.m_sName + ":" + CStr(oBinItem.m_lSize) + "], "
Next
If Len(sResult) > 2 Then sResult = Left(sResult, Len(sResult) - 2)
GetString = sResult
End Function
5.1.8. CBinItem 类源代码
实现要放入 Bin 的 Item。
- 项目的名称由 m_sName 管理,大小由 m_lSize 管理。
- CompareTo函数:返回当前项与待比较项的大小比较结果。
Option Explicit
Public m_sName As String
Public m_lSize As Long
'BinItem의 size 비교 함수
' - parameter: 비교대상 BinItem(B)
' - 비교기준: 자기자신 BinItem(A)
'Return 값(Long type)
' 0: 동일함 (A = B)
' 1: 비교대상 BinItem이 더 큼(A < B)
' -1: 자기자신 BinItem이 더 큼(A > B)
Public Function CompareTo(oBinItem As CBinItem) As Long
Dim i As Long
If Me.m_lSize = oBinItem.m_lSize Then
i = 0
ElseIf Me.m_lSize < oBinItem.m_lSize Then
i = -1
Else
i = 1
End If
CompareTo = i
End Function
5.1.9. CTimer 类源代码
它用于准确测量每个算法的执行时间。
资源: https://stackoverflow.com/questions/198409/how-do-you-test-running-time-of-vba-code
Option Explicit
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Private m_CounterStart As LARGE_INTEGER
Private m_CounterEnd As LARGE_INTEGER
Private m_crFrequency As Double
Private Const TWO_32 = 4294967296# ' = 256# * 256# * 256# * 256#
Private Function LI2Double(LI As LARGE_INTEGER) As Double
Dim Low As Double
Low = LI.lowpart
If Low < 0 Then
Low = Low + TWO_32
End If
LI2Double = LI.highpart * TWO_32 + Low
End Function
Private Sub Class_Initialize()
Dim PerfFrequency As LARGE_INTEGER
QueryPerformanceFrequency PerfFrequency
m_crFrequency = LI2Double(PerfFrequency)
End Sub
Public Sub StartCounter()
QueryPerformanceCounter m_CounterStart
End Sub
Property Get TimeElapsed() As Double
Dim crStart As Double
Dim crStop As Double
QueryPerformanceCounter m_CounterEnd
crStart = LI2Double(m_CounterStart)
crStop = LI2Double(m_CounterEnd)
'TimeElapsed = 1000# * (crStop - crStart) / m_crFrequency
TimeElapsed = Round((crStop - crStart) / m_crFrequency, 4)
End Property
<< 相关文章列表 >>








