Nhờ các cao thủ thông não giúp e với ạ. trình độ e còn xanh quá nên ko hiểu cái này là như thế nào cả... cảm ơn các bác
Option Explicit
Type BarElement
Mark As String
Diameter As Byte
Quantity As Long
No As Long
Length As Double
End Type
Type BarDetail
Dia As Byte
MaxNum As Byte
TotalNum As Integer
CurrentNum As Integer
Mark As String
Length As Double
MinLength As Double
End Type
Public Type SumLength
Value As Double
Note As String
End Type
Public maxLength As Double
Public maxResult As Double
Public maxString As String
Public tmpBar As Integer
Public tmpNum As Byte
Public barIndex As Long
Public cutIndex As Long
Public lapLength As Double
Public devLength As Double
Public cutOption As Byte
Public constPI As Double
Public isDemo As Boolean
Public Sub CutBarMainControl()
Call GetInitialData
'isDemo = True
'If InStr(Application.Caption, "REGISTERED") <> 0 Then isDemo = True
'isDemo = True
'If isDemo = True Then
' If MsgBox("Not registered vesion. Run DEMO program?", vbInformation + vbYesNoCancel, "Before running") = vbYes Then
' 'Call mdlCreateRandom.CreateRandom
' Call SortInputData
' Else
' If MsgBox("Not registered vesion. Run DEMO program?", vbInformation + vbYesNoCancel, "Before running") = vbNo Then
' Load frmActivate
' frmActivate.Show
' End If
' End If
' Else
Call SortInputData
'End If
End Sub
Private Sub GetInitialData()
maxLength = Sheets("Input").Cells(2, 6)
devLength = Sheets("Input").Cells(3, 6)
lapLength = Sheets("Input").Cells(4, 6)
cutOption = Sheets("Input").Cells(5, 6)
cutIndex = 0
constPI = Application.WorksheetFunction.Pi()
'Clear old data in sheet Result
Sheets("Result").Activate
Cells(1, 5) = 0
Range("A4:K65536").Clear 'Number of row in a sheet is 65536
End Sub
Private Sub SortInputData()
ActiveWorkbook.Application.StatusBar = "Analyzing and sorting data..."
Dim arrDiameter(1 To 15) As Byte
Dim arrWeight(1 To 15) As Double
Dim arrBar(1 To 15, 1 To 500) As BarElement
Dim arrNum(1 To 15) As Long
Dim curBarDia As Byte
Dim curBarLength As Double
Dim curBarMark As String
Dim curBarQuantity As Long
Dim curBarNo As Long
Dim i&, j&, l&
Dim k As Byte
Dim tmpMu As Integer
'Initilize list of support Diameters
For i = 1 To 15
arrDiameter(i) = Sheets("Input").Cells(2, i + 8)
Next i
For i = 1 To 15
arrNum(i) = 0
arrWeight(i) = 0
Next i
'Set initial Cell Index
i = 9
Sheets("Input").Activate
Do While Trim(Cells(i, 4)) <> "" 'Cot duong kinh khac 0
Cells(i, 2) = i - 8
curBarNo = i - 8
curBarMark = Trim(Cells(i, 3))
curBarDia = Trim(Cells(i, 4))
curBarQuantity = Trim(Cells(i, 5))
curBarLength = Trim(Cells(i, 6))
For j = 1 To 15
If arrDiameter(j) = curBarDia Then
arrNum(j) = arrNum(j) + 1
arrBar(j, arrNum(j)).No = curBarNo
arrBar(j, arrNum(j)).Mark = curBarMark
arrBar(j, arrNum(j)).Diameter = curBarDia
arrBar(j, arrNum(j)).Quantity = curBarQuantity
arrBar(j, arrNum(j)).Length = curBarLength
arrWeight(j) = arrWeight(j) + (((curBarDia ^ 2 * constPI / 4) * curBarLength) * 7850 * curBarQuantity) / 1000000
Exit For
End If
Next j
i = i + 1
Loop
Range("B9:G" & i - 1).Select
Call FormatInputTable
Range("B9:C" & i - 1).Select
Selection.HorizontalAlignment = xlCenter
'Dien DK va khoi luong vao Remain
For i = 1 To 15
Sheets("Remain").Cells(i + 3, 7) = arrDiameter(i)
Sheets("Remain").Cells(i + 3, 8) = arrWeight(i)
Next i
Sheets("Result").Activate
For j = 1 To 15
If arrNum(j) > 0 Then
ActiveWorkbook.Application.StatusBar = "Filtering data to Diameter: " & arrDiameter(j)
'Get current row index
barIndex = Cells(1, 5)
'Transfer data to ActiveSheet
l = 0
For i = 1 To arrNum(j)
l = l + 1
If arrBar(j, i).Length > maxLength Then
tmpMu = Int(arrBar(j, i).Length / (maxLength - lapLength * arrDiameter(j) / 1000))
Cells(barIndex + l + 3, 1) = arrBar(j, i).No
Cells(barIndex + l + 3, 2) = arrBar(j, i).Diameter
Cells(barIndex + l + 3, 3) = arrBar(j, i).Mark
Cells(barIndex + l + 3, 4) = arrBar(j, i).Quantity * tmpMu
Cells(barIndex + l + 3, 5) = maxLength
l = l + 1
arrBar(j, i).Length = arrBar(j, i).Length - tmpMu * (maxLength - lapLength * arrDiameter(j) / 1000)
End If
Cells(barIndex + l + 3, 1) = arrBar(j, i).No
Cells(barIndex + l + 3, 2) = arrBar(j, i).Diameter
Cells(barIndex + l + 3, 3) = arrBar(j, i).Mark
Cells(barIndex + l + 3, 4) = arrBar(j, i).Quantity
Cells(barIndex + l + 3, 5) = arrBar(j, i).Length
Next i
Cells(1, 5) = Cells(1, 5) + l
'Sort data
Range("A" & barIndex + 3 & ":E" & barIndex + l + 3).Select
Selection.Sort key1:=Range("E" & barIndex + 3), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWorkbook.Application.StatusBar = "Opimizing cutting bar for Diameter: " & arrDiameter(j)
'Format data from column A to D
Range("A" & barIndex + 4 & "
" & barIndex + l + 3).Select
Selection.NumberFormat = "0"
Selection.HorizontalAlignment = xlCenter
'Format data from column A to E
Range("E" & barIndex + 4 & ":E" & barIndex + l + 3).Select
Selection.NumberFormat = "0.000"
'Format cell borders
Range("A" & barIndex + 4 & ":E" & barIndex + l + 3).Select
Call FormatInputTable
Call CutbarAnalyze(arrDiameter(j))
Range("A" & barIndex + 3 & ":E" & barIndex + l + 3).Select
Selection.Sort key1:=Range("A" & barIndex + 3), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
Next j
ActiveWorkbook.Application.StatusBar = "Controlling remain steel for the next usage"
Cells(1, 9) = "Optimization finished!"
Call ControlRemainSteel
ActiveWorkbook.Application.StatusBar = "Ready"
End Sub
Private Sub ClearCurrentSheet(intCount As Long)
Dim i&, j&
Cells(1, 6) = ""
i = 4
Do While Trim(Cells(i, 5) <> "")
i = i + 1
Loop
j = i
If intCount >= j Then j = intCount
Rows("4:" & j).Select
Selection.Delete Shift:=xlUp
End Sub
Private Sub CutbarAnalyze(curBarDiameter)
Dim i&, j&, k&, l&, m&, iPos&
Dim sCnt&, iCnt&
Dim MaxBar As Long
Dim iniLength As Double
Dim useLength As Double
Dim resLength As Double
Dim maxNumUse As Long
Dim strKey As String
Dim strAnl As String
Dim curMaxNum As Byte
Dim curBar() As BarDetail
Dim curNum() As Integer
Dim curFac() As Integer
Dim curSumLength(1 To 500) As SumLength
Dim curSumMin(1 To 500) As SumLength
Dim curCOM(1 To 500) As SumLength
Dim strNum(1 To 500) As String
Dim strDisplay As String
'Get MaxBar form current sheet
MaxBar = Cells(1, 5)
'ReDefined array
If MaxBar > 0 Then
ReDim curBar(1 To MaxBar) As BarDetail
ReDim curNum(1 To MaxBar) As Integer
ReDim curFac(1 To MaxBar) As Integer
iniLength = 0
useLength = 0
For i = barIndex + 1 To MaxBar
curBar(i).Mark = Cells(i + 3, 3)
curBar(i).TotalNum = Cells(i + 3, 4)
curBar(i).CurrentNum = Cells(i + 3, 4)
curBar(i).Length = Cells(i + 3, 5)
iniLength = iniLength + curBar(i).Length * curBar(i).TotalNum
curBar(i).MinLength = curBar(i).Length * (1 - devLength)
curBar(i).MaxNum = Fix(maxLength / curBar(i).MinLength)
Next i
'Cells index to put result
i = 1
iPos = 4
Do While i <= MaxBar
Do While curBar(i).CurrentNum > 0
sCnt = 0
For j = 1 To minValue(curBar(i).MaxNum, curBar(i).CurrentNum)
sCnt = sCnt + 1
curSumLength(sCnt).Value = j * curBar(i).Length
curSumMin(sCnt).Value = j * curBar(i).MinLength
curSumLength(sCnt).Note = "Bar" & i & "Num" & j
Next j
k = i + 1
Do While k <= MaxBar
If curBar(k).CurrentNum > 0 Then
m = 0
For iCnt = 1 To sCnt
For l = 1 To minValue(curBar(k).MaxNum, curBar(k).CurrentNum)
'curSumLength(iCnt).Value + l * curBar(k).Length <= maxlength Or
If curSumMin(iCnt).Value + l * curBar(k).MinLength <= maxLength Then
m = m + 1
curSumLength(sCnt + m).Value = curSumLength(iCnt).Value + l * curBar(k).Length
curSumMin(sCnt + m).Value = curSumMin(iCnt).Value + l * curBar(k).MinLength
curSumLength(sCnt + m).Note = curSumLength(iCnt).Note & "Bar" & k & "Num" & l
End If
Next l
Next iCnt
sCnt = sCnt + m
End If
k = k + 1
Loop
Call get_MaxResult(curSumLength, sCnt)
'Get conresponded num of bar in this case -> curNum(1 To MaxBar)
For j = 1 To MaxBar
curNum(j) = 0
Next j
j = 2
Do While j <= Len(maxString)
strKey = Mid(maxString, j, 3)
If strKey = "Bar" Then
strAnl = Left(maxString, j - 1)
Call get_NumBar(strAnl)
curNum(tmpBar) = tmpNum
maxString = Right(maxString, Len(maxString) - j + 1)
j = 2
Else
j = j + 1
End If
Loop
Call get_NumBar(maxString)
curNum(tmpBar) = tmpNum
'Get maximun combination in this case -> maxNumUse(curNum, curBar.CurrentNum)
For j = 1 To MaxBar
If curNum(j) <> 0 Then
curFac(j) = curBar(j).CurrentNum \ curNum(j)
Else
curFac(j) = 0
End If
Next j
maxNumUse = maxArray(curFac)
For j = 1 To MaxBar
If maxNumUse >= curFac(j) Then
If curFac(j) > 0 Then
maxNumUse = curFac(j)
End If
End If
Next j
'Write analysis result to sheet
'Writing diameter
'barIndex = get_CurrentIndex()
Cells(cutIndex + iPos, 7) = curBarDiameter
'Writing cut No.
Cells(cutIndex + iPos, 8) = iPos - 3
strDisplay = ""
resLength = 0
For j = 1 To MaxBar
If curNum(j) > 0 Then
strDisplay = strDisplay & curNum(j) & "*[" & curBar(j).Mark & "]+"
resLength = resLength + curNum(j) * curBar(j).Length
End If
Next j
strDisplay = Left(strDisplay, Len(strDisplay) - 1)
Cells(cutIndex + iPos, 9) = strDisplay
Cells(cutIndex + iPos, 10) = maxNumUse
Cells(cutIndex + iPos, 11) = resLength
useLength = useLength + maxLength * maxNumUse
For j = 1 To MaxBar
curBar(j).CurrentNum = curBar(j).CurrentNum - maxNumUse * curNum(j)
Next j
iPos = iPos + 1
Loop
i = i + 1
Loop
'Format cell borders
Range("G" & cutIndex + 4 & ":K" & cutIndex + iPos - 1).Select
Call FormatInputTable
'Number format
Range("K" & cutIndex + 4 & ":K" & cutIndex + iPos - 1).Select
Selection.NumberFormat = "0.000"
cutIndex = cutIndex + iPos - 4
End If
End Sub
Private Sub ControlRemainSteel()
Dim arrDiameter(1 To 15) As Byte
Dim arrMinLength(1 To 15) As Double
Dim arrRealWeigth(1 To 15) As Double
Dim tmpWeight As Double
Dim i%, j%, k%
Dim curMinLength As Double
For i = 1 To 15
arrMinLength(i) = Sheets("Input").Cells(3, i + 8)
arrDiameter(i) = Sheets("Input").Cells(2, i + 8)
Next i
'Clear old data in this sheet
Sheets("Remain").Activate
Range("A4:E65536").Clear
'For i = 1 To 15
'Filter remain steel for next usage
j = 4
k = 0
Do While Trim(Sheets("Result").Cells(j, 9)) <> ""
For i = 1 To 15
If Sheets("Result").Cells(j, 7) = arrDiameter(i) Then
curMinLength = arrMinLength(i)
Exit For
End If
Next i
If maxLength - Sheets("Result").Cells(j, 11) >= curMinLength Then
k = k + 1
Cells(k + 3, 1) = k
Cells(k + 3, 2) = Sheets("Result").Cells(j, 7)
Cells(k + 3, 3) = Sheets("Result").Cells(j, 8)
Cells(k + 3, 4) = Sheets("Result").Cells(j, 10)
Cells(k + 3, 5) = maxLength - Sheets("Result").Cells(j, 11)
End If
j = j + 1
Loop
'Format number
Range("E4:E" & k + 3).Select
Selection.NumberFormat = "0.000"
'Format range
Range("A4:E" & k + 3).Select
Call FormatInputTable
'Get reality weight
j = 4
Do While Trim(Sheets("Result").Cells(j, 9)) <> ""
For i = 1 To 15
If Sheets("Result").Cells(j, 7) = arrDiameter(i) Then
tmpWeight = arrDiameter(i) ^ 2 * constPI / 4 / 10 ^ 6
tmpWeight = tmpWeight * Sheets("Result").Cells(j, 10) * maxLength * 7850
arrRealWeigth(i) = arrRealWeigth(i) + tmpWeight
Exit For
End If
Next i
j = j + 1
Loop
'Writing data
For i = 1 To 15
Cells(i + 3, 9) = arrRealWeigth(i)
Next i
'Next i
End Sub
Public Function minValue(valA, valB) As Double
minValue = valA
If minValue >= valB Then minValue = valB
End Function
Private Sub get_MaxResult(arrBar() As SumLength, arrCnt As Long)
maxResult = arrBar(1).Value
maxString = arrBar(1).Note
Dim i&
For i = 1 To arrCnt
If arrBar(i).Value >= maxResult Then
maxResult = arrBar(i).Value
maxString = arrBar(i).Note
End If
Next i
End Sub
Private Sub get_NumBar(strGet)
tmpNum = 0
tmpBar = 0
Dim i1 As Integer
For i1 = 1 To Len(strGet)
If Mid(strGet, i1, 3) = "Num" Then
tmpBar = Right(Left(strGet, i1 - 1), Len(Left(strGet, i1 - 1)) - 3)
tmpNum = Right(Right(strGet, Len(strGet) - i1 + 1), Len(Right(strGet, Len(strGet) - i1 + 1)) - 3)
Exit For
End If
Next i1
End Sub
Private Function maxArray(arrFac() As Integer) As Integer
maxArray = 0
Dim iArr As Integer
For iArr = LBound(arrFac) To UBound(arrFac)
If maxArray <= arrFac(iArr) Then maxArray = arrFac(iArr)
Next iArr
End Function
Private Function Num2Char(intNum As Integer) As String
Num2Char = ""
Do While intNum > 26
Num2Char = Chr(64 + intNum Mod 26) & Num2Char
intNum = intNum \ 26
Loop
Num2Char = Chr(64 + intNum) & Num2Char
End Function
Private Function get_CurrentIndex()
Dim cIndex As Long
cIndex = 4
Do While Trim(Cells(cIndex, 7)) <> ""
cIndex = cIndex + 1
Loop
get_CurrentIndex = cIndex
End Function
Private Sub FormatInputTable()
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
End Sub
