Kesim Listesi Hakkında

[Serkan_71]

Herkese merhaba ,

Tek eksenli kesim listesi oluşmak istiyorum.
Boy : 366 cm

Listede 1 den 20 kadar gruplar var .

Bu grupların yanlarında kesim ölçüleri bulunmaktadır.

Kesim ölçüleri en uygun şekilde 366 uygun olacak ancak oluşturulan tabloda ilgili ölçünün yanında hangi gruba ait olduğu da yer alması gerekmektedir.

Gruplar - Ölçüler
1- 50 60 66 55 67 Örnek Tabloda : 360/ 2 60 /1 gibi
2- 360 5 50 36 10


Yardımlarınız İçin Şimdiden Teşekkürler..

 

[ragnorak]

Bu bir makineye aktarmak için mi lazım?

 

[Serkan_71]

İmalat aşamasında kesim yapan ustanın ölçülerle hesaplama ile uğraşmaması için en uygun sıralamayı yapmak istiyorum.

Makineye aktarım söz konusu değildir.

 

[ragnorak]

"366" dan anladığım bu bir Melamin Yonga Levha kesimi. Tek eksenli istemişsiniz bu nedenle kesilecek plaka ölçülerinin sabit genişlikte olduğunu düşünüyorum. Aşağıdaki link işinizi görebilir diye düşünüyorum.
https://www.excel.web.tr/threads/excel-bir-boyutlu-kesim-optimizasyonu.157101/

 

[Serkan_71]

Cevabınız için teşekkürler .

Kesim listesini hazırlamada kullanılabilir ancak grup numaralarının da yer almasını istiyorum .

 

[Serkan_71]

İlgili komutu buldum ancak message box şeklinde cevaplamaktadır.

benim istediğim başka sayfaya aktarmasıdır.

Yardımcı olabilir misiniz ?

Option Explicit

Sub ComputeStock()

Dim CutArr() As Double, DetStk() As Double

Dim R As Long
Dim lRowCount As Long
Dim i As Long, j As Long, k As Long

Dim temp As Double, temp2 As Double

Dim TotStk As Double, TmpStk As Double
Dim MinCut As Double, TotCut As Double
Dim dStk As Double

Dim rInpStk As Range
Dim rInputCuts As Range
Dim rLastEntry As Range
Dim AllZero As Boolean
Dim sMsg As String, sTtl As String
Dim cell As Range

Set rLastEntry = wshCuts.Range("A" & wshCuts.Rows.Count).End(xlUp)
Set rInpStk = wshCuts.Range("InpStock")

'Make sure cuts have been entered
If rLastEntry.Address = "$A$1" Then
Exit Sub
Else
Set rInputCuts = wshCuts.Range("A2", rLastEntry.Address).Resize(, 2)
lRowCount = rInputCuts.Rows.Count
End If

'Check for non-numeric data and negative numbers
For Each cell In rInputCuts.Cells
If Not IsNumeric(cell.Value) Then
MsgBox "Your selected range contains non-numeric data"
Exit Sub
End If
If cell.Value < 0 Then
MsgBox "All values must be positive"
Exit Sub
End If
Next cell

'Make sure stock lenght was entered
If IsEmpty(rInpStk.Value) Or Not IsNumeric(rInpStk.Value) Or rInpStk.Value <= 0 Then
MsgBox "Stock length must be a positive number"
Exit Sub
Else
dStk = rInpStk.Value
End If

ReDim CutArr(lRowCount - 1, 1)

'Fill array with cuts
For i = 0 To UBound(CutArr, 1)
For j = 0 To UBound(CutArr, 2)
CutArr(i, j) = rInputCuts.Cells(i + 1, j + 1)
Next j
Next i

'Sort array descending on cut length
For i = 0 To UBound(CutArr, 1) - 1
For j = i + 1 To UBound(CutArr, 1)
If CutArr(i, 1) < CutArr(j, 1) Then
temp = CutArr(j, 0)
temp2 = CutArr(j, 1)
CutArr(j, 0) = CutArr(i, 0)
CutArr(j, 1) = CutArr(i, 1)
CutArr(i, 0) = temp
CutArr(i, 1) = temp2
End If
Next j
Next i

'Make sure all cuts can be made with stock lenght
If CutArr(0, 1) > dStk Then
MsgBox "At least one cut is greater than the stock length."
Exit Sub
End If

'Initialize variables
MinCut = CutArr(UBound(CutArr), 1)
TmpStk = dStk
TotCut = 1 'set > 0 to start loop, TotCut is
'recalced within loop
i = 0
k = 0

'TotCut is sum of first dimensions in array
Do While TotCut > 0

'MinCut is smallest 2nd dimension where 1st
'dimension is > 0
Do While TmpStk >= MinCut
If CutArr(i, 1) <= TmpStk And CutArr(i, 0) > 0 Then

'Reduce current stock length by cut length
TmpStk = TmpStk - CutArr(i, 1)

'Reduce number of current cut by 1
CutArr(i, 0) = CutArr(i, 0) - 1

'Store current cut length
ReDim Preserve DetStk(1, k)
DetStk(0, k) = TotStk + 1
DetStk(1, k) = CutArr(i, 1)
k = k + 1
Else
'Move to next cut length
i = i + 1
End If

'Reset MinCut
AllZero = True
For j = LBound(CutArr) To UBound(CutArr)
If CutArr(j, 0) > 0 Then
MinCut = CutArr(j, 1)
AllZero = False
End If
Next j
'If there are no cut pieces remaining, get out
If AllZero Then
Exit Do
End If
Loop

'Reset TmpStk and add one to TotStk
TmpStk = dStk
TotStk = TotStk + 1

'Reset i to row of largest 2nd dimension whose
'1st dimension is not zero
For j = UBound(CutArr) To LBound(CutArr) Step -1
If CutArr(j, 0) <> 0 Then
i = j
End If
Next j

'Reset TotCut to sum of all 1st
'dimensions
TotCut = 0
For j = LBound(CutArr) To UBound(CutArr)
TotCut = TotCut + CutArr(j, 0)
Next j
Loop

'Output totals to a message box
sTtl = "Total stock at " & dStk & " = " & TotStk

sMsg = "Board No." & vbTab & "Cut Lenght" & vbCrLf

For k = LBound(DetStk, 2) To UBound(DetStk, 2)
sMsg = sMsg & DetStk(0, k) & vbTab & vbTab _
& DetStk(1, k) & vbCrLf
Next k

MsgBox sMsg, vbOKOnly, sTtl

End Sub