Option Explicit
'===========================================================================================
'Алгоритм генерации схем раскроя, оптимальных по Парето
'Автор - MCH (Михаил Ч.) август 2018 год, m-ch@mail.ru
'UPD 09/06/2019
'Минорные изменения для удобства (субъективно): Jack Famous
'Тема на Планете: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=117795&TITLE_SEO=117795-kombinatorika-raskroy-armatury
'===========================================================================================
Const MAXLEN As Long = 100 'максимальное количество различных элементов
'===========================================================================================
Type cspSchema 'тип данных для хранения схемы раскроя прутка
b(1 To MAXLEN) As Long ' массив колличеств
S As Long ' сумма элементов
End Type
'===========================================================================================
Type cspData 'тип данных для хранения исходной инвормации о раскраиваемых даных
l As Long 'рамер прутка
m As Long 'количество раличных элементов
n As Long 'общее количество элементов
a(1 To MAXLEN) As Long 'массив длин
b(1 To MAXLEN) As Long 'массив колличеств
i(1 To MAXLEN) As Long 'массив индексов
S As Long 'сумма элементов
End Type
'===========================================================================================
Private Sub Start()
Dim x, arrData, r&, j&, a&, b&, clm&, t!
Dim csp As cspData, sch As cspSchema, arrSchema(), arrSum(), arrOut()
Const iMax& = 1000000
If Not InputNumberAsText(x, "Введите РАЗМЕР заготовки:") Then Exit Sub
csp.l = x: t = Timer: arrData = [_start].Value2
For r = 1 To UBound(arrData, 1)
x = arrData(r, 1)
If Not IsCorrectNumber(x) Then MsgBox "Размер заготовки в строке №" & r & " ДОЛЖЕН быть ЦЕЛЫМ ПОЛОЖИТЕЛЬНЫМ числом!", vbCritical, "ОШИБКА АЛГОРИТМА": Exit Sub
If x > csp.l Then MsgBox "Размер заготовки в строке №" & r & " НЕ ДОЛЖЕН превышать РАЗМЕР заготовки «" & csp.l & "»", vbCritical, "ОШИБКА АЛГОРИТМА": Exit Sub
a = x: x = arrData(r, 2)
If Not IsCorrectNumber(x) Then MsgBox "КОЛ-ВО деталей в строке №" & r & " ДОЛЖНО быть ЦЕЛЫМ ПОЛОЖИТЕЛЬНЫМ числом!", vbCritical, "ОШИБКА АЛГОРИТМА": Exit Sub
b = x
j = j + 1
csp.m = j
csp.n = csp.n + b
csp.a(j) = a
csp.b(j) = b
csp.i(j) = j
csp.S = csp.S + a * b
Next r
SortCspItem csp
' генерация всех схем, оптимальных по Парето ===============================================
' жадный алгоритм
sch = fddSchema(csp, csp.l): ReDim arrSchema(iMax - 1): ReDim arrSum(iMax - 1): r = 0
' перебор всех вариантов
Do While sch.S > 0
r = r + 1: If r > iMax Then r = iMax: Exit Do
arrSchema(r - 1) = SchemaToText(csp, sch, csp.m)
arrSum(r - 1) = sch.S
sch = NextShema(csp, sch)
Loop
ReDim arrOut(1 To r, 1 To 4)
For r = 1 To UBound(arrOut, 1)
arrOut(r, 1) = arrSchema(r - 1)
arrOut(r, 2) = Len(arrOut(r, 1)) - Len(Replace$(arrOut(r, 1), ":", ""))
arrOut(r, 3) = arrSum(r - 1)
arrOut(r, 4) = csp.l - arrOut(r, 3)
Next r
Erase arrSchema: Erase arrSum
Application.ScreenUpdating = False
On Error Resume Next: [_tblSchema].EntireRow.Delete: On Error GoTo 0
shTbl.Cells(2, 1).Resize(UBound(arrOut, 1), 4).Value2 = arrOut
Application.Calculate:: shTbl.Range("A1:D1").EntireColumn.AutoFit: Call TableSort
shTbl.Select: Application.ScreenUpdating = True
MsgBox "Успешно сгенерировано схем: " & UBound(arrOut, 1) & vbLf & "Время работы макроса: " & Format$(Timer - t, "0.00 сек."), vbInformation, "ГОТОВО"
End Sub
'===========================================================================================
'===========================================================================================
Private Sub SortCspItem(csp As cspData) 'сортировка элементов массива по убыванию (простая сортировка, можно улучшить алгоритм для большого количества различных элементов)
Dim i&, j&, tmp&
For i = 1 To csp.m - 1
For j = i + 1 To csp.m
If csp.a(i) < csp.a(j) Then
tmp = csp.a(i): csp.a(i) = csp.a(j): csp.a(j) = tmp
tmp = csp.b(i): csp.b(i) = csp.b(j): csp.b(j) = tmp
tmp = csp.i(i): csp.i(i) = csp.i(j): csp.i(j) = tmp
End If
Next j, i
End Sub
'===========================================================================================
Private Function fddSchema(csp As cspData, S As Long, Optional m1 As Long = 1) As cspSchema 'нахождение схемы жадным алгоритмом, гдк "s" - искомая сумма, а "m1" - начальная позиция, с какой детали будем искать решение
Dim sch As cspSchema, i&, n&
If m1 < 1 Then m1 = 1 'проверка на корректность ввода
For i = m1 To csp.m
n = Int((S - sch.S) / csp.a(i))
If n > csp.b(i) Then n = csp.b(i)
sch.b(i) = n
sch.S = sch.S + n * csp.a(i)
Next i
fddSchema = sch
End Function
'===========================================================================================
Private Function NextShema(csp As cspData, sch As cspSchema) As cspSchema 'расчет следующей схемы раскроя на основе имеющейся
Dim sch2 As cspSchema, i&, j&, S&
S = sch.S
For i = csp.m - 1 To 1 Step -1
S = S - sch.b(i + 1) * csp.a(i + 1)
If sch.b(i) > 0 Then
sch2 = fddSchema(csp, csp.l - S + csp.a(i), i + 1)
If sch2.S > csp.l - S Then
For j = 1 To i - 1
sch2.b(j) = sch.b(j)
sch2.S = sch2.S + sch2.b(j) * csp.a(j)
Next j
sch2.b(i) = sch.b(i) - 1
sch2.S = sch2.S + sch2.b(i) * csp.a(i)
Exit For
End If
End If
Next i
If i > 0 Then NextShema = sch2
End Function
'===========================================================================================
'===========================================================================================
Private Function SchemaToText(csp As cspData, sch As cspSchema, Optional m& = 0) As String
Dim x, arrNum(), arrCount() As Long, arrInd() As Long, arrOut() As String, i&, n&
If m = 0 Then m = MAXLEN
ReDim arrInd(m - 1): ReDim arrNum(m - 1): ReDim arrCount(m - 1): n = -1
For i = 1 To m
If sch.b(i) > 0 Then
n = n + 1
arrInd(n) = n
arrNum(n) = csp.i(i)
arrCount(n) = sch.b(i)
End If
Next i
ReDim Preserve arrInd(n): ReDim Preserve arrNum(n): Call Array1xSortInd(arrNum, arrInd, 0, n)
ReDim arrOut(n): n = -1
For Each x In arrInd
n = n + 1: arrOut(n) = "№" & arrNum(n) & ": " & arrCount(x)
Next x
Erase arrNum: Erase arrCount: SchemaToText = Join(arrOut, " | ")
End Function
'===========================================================================================
'===========================================================================================
Private Function InputNumberAsText(tmpNum, txtTitle$) As Boolean
Dim flag As Boolean
reinp: If flag Then MsgBox "Некорректное ЧИСЛО!", vbCritical, "ОШИБКА ВВОДА"
inp: tmpNum = Application.InputBox(txtTitle, "Введите ЦЕЛОЕ ПОЛОЖИТЕЛЬНОЕ число", CStr(tmpNum), Type:=2)
If tmpNum = "False" Then Exit Function
If Not IsCorrectNumber(tmpNum) Then flag = True: GoTo reinp
InputNumberAsText = True
End Function
'-------------------------------------------------------------------------------------------
Private Function IsCorrectNumber(num) As Boolean
Dim x: On Error GoTo er
For Each x In Array(".", ",", "/", "-")
If InStr(1, num, x) Then Exit Function
Next x
x = --num * 1: If Not IsNumeric(x) Then Exit Function
If x <> Fix(x) Then Exit Function
If x <= 0 Then Exit Function
num = x: IsCorrectNumber = True
er: End Function
'===========================================================================================
Private Sub TableSort()
With shTbl.ListObjects(1).Sort
.SortFields.Clear
.SortFields.Add2 Key:=Range("tbl[COUNT]"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add2 Key:=Range("tbl[LESS]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add2 Key:=Range("tbl[SCHEMA]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
'===========================================================================================
'===========================================================================================
Private Sub Array1xSortInd(arrVal(), arrInd() As Long, l&, u&)
Dim x, y, i&, j&
i = l: j = u: x = arrVal((l + u) \ 2)
Do
Do While arrVal(i) < x: i = i + 1: Loop
Do While x < arrVal(j): j = j - 1: Loop
If i <= j Then
y = arrVal(i): arrVal(i) = arrVal(j): arrVal(j) = y
y = arrInd(i): arrInd(i) = arrInd(j): arrInd(j) = y
i = i + 1: j = j - 1
End If
Loop Until i > j
If l < j Then Call Array1xSortInd(arrVal, arrInd, l, j)
If i < u Then Call Array1xSortInd(arrVal, arrInd, i, u)
End Sub
'===========================================================================================
'=========================================================================================== |
вот это однозначно крутая штука! Спасибо большое! 
