Please Help Me

[AndreasLim92]

I am trying to Compare Material of Size and Part with Part of Type of Size.
I have done with Cutting Plan from Part of Length with Material Length.
But all of Parts get cutting off all Material without check the type and size.

I want to cut but with the same type and size.
Please help me to solve this function.

Option Explicit

Sub Ø‚èo‚µ()
'Reading
Dim z As Variant               '//Material List
Dim p As Variant               '//List of parts
Dim i As Integer, j As Integer '//Loop Counter
Dim tmp As Long                '//Provisional Calculation of Materials and Parts
Dim input_z_row As Integer: input_z_row = Range("D5").Row       '//Materials Data Input
Dim input_z_column As Integer: input_z_column = Range("D5").Column '//Materials Data Input
Dim input_r_row As Integer: input_r_row = Range("I5").Row       '//Parts Data Input
Dim input_r_column As Integer: input_r_column = Range("I5").Column '//Parts Data Input
Dim yotyou As Integer: yotyou = Sheets(1).Cells(1, 2) '//Margin Length
Dim kiri As Integer: kiri = Sheets(1).Cells(2, 2)  '//Cutting Off

Sheets(1).Activate
Sheets(1).Range("B4:E" & Range("D4").End(xlDown).Row).Sort _
key1:=Sheets(1).Range("D4"), order1:=xlDescending, Header:=xlYes

z = Range(Cells(input_z_row, input_z_column), Cells(Cells(Rows.Count, input_z_column).End(xlUp).Row, input_z_column + 1)) 'Materials Length in Storage
p = Range(Cells(input_r_row, input_r_column), Cells(Cells(Rows.Count, input_r_column).End(xlUp).Row, input_r_column + 1)) 'Parts Length in Storage

'//Materials - Convert Legnth
For i = 1 To UBound(z, 1)
   tmp = tmp + z(i, 2)
Next i
ReDim z1(1 To tmp, 1 To 2) As Long '//Materials Length List
tmp = 1
For i = 1 To UBound(z, 1)
   For j = 1 To z(i, 2)
      z1(tmp, 1) = z(i, 1) - yotyou
      z1(tmp, 2) = 1 '1:Unused Materials
      tmp = tmp + 1
   Next j
Next i
'//Parts - Convert Length
tmp = 0
For i = 1 To UBound(p, 1)
   tmp = tmp + p(i, 2)
Next i
ReDim p1(1 To tmp, 1 To 2) As Long '//•”Þ‚Ì’·‚³ƒŠƒXƒg
tmp = 1
For i = 1 To UBound(p, 1)
   For j = 1 To p(i, 2)
      p1(tmp, 1) = p(i, 1) + kiri
      p1(tmp, 2) = 0 '0:NO@1:YES
      tmp = tmp + 1
   Next j
Next i

'Calculation Cutting
ReDim d_m(0 To UBound(p1, 1), 1 To UBound(z1, 1)) As Long '//Definite Array
ReDim t_p(1 To UBound(p1, 1)) As Long                     '//Temporay Parts List
ReDim t_m(0 To UBound(p1, 1)) As Long                     '//Temporay Optimal Cutting
Dim c_t As Long                                           '//Materials Counter
Dim new_j As Long                                         '//Materials Used Number
Dim g() As Long                                           '//Function better Array
Dim n_l As Long, t_t As Long                              '//n_l:Materials Length Now@t_t:Number of test
Dim n As Integer, k As Integer, check As Integer
For c_t = 1 To UBound(z1, 1) '//Materials Looping
   '//Create Unjoined Parts List
   For i = 1 To UBound(p1, 1)
      If p1(i, 2) = 0 Then
         t_p(i) = p1(i, 1)
      Else
         t_p(i) = 0
      End If
   Next i
  
   '//If the Unjoined All Parts List is O, Considers for Joining
   If exist1(t_p) = 0 Then
      Exit For
   End If
   '/Materials Pick Up
   new_j = 0
   t_t = 0
   For j = 1 To UBound(z1, 1)
      If j = 1 Then
         If z1(j, 2) = 1 Then
            n_l = z1(j, 1)
            t_t = t_t + 1
            check = 1
         End If
      Else
         If z1(j, 1) = z1(j - 1, 1) And z1(j - 1, 2) = 1 Then
         ElseIf z1(j, 2) = 1 Then
            n_l = z1(j, 1)
            t_t = t_t + 1
            check = 1
         End If
      End If
      
      If check = 1 Then
         g = better(t_p, n_l)
         If t_t = 1 And exist1(g) <> 0 Then
            For k = 0 To UBound(g)
               t_m(k) = g(k)
            Next k
            new_j = j
         Else
            If t_m(0) > g(0) And exist1(g) <> 0 Then
               For k = 0 To UBound(g)
                  t_m(k) = g(k)
               Next k
               new_j = j
            End If
         End If
      End If
      check = 0
   Next j
  
   '/Optimal Solution
   d_m(0, c_t) = new_j
   For n = 1 To UBound(p1, 1)
      d_m(n, c_t) = t_m(n)
   Next n
   For n = 1 To UBound(p1, 1)
      If t_m(n) = 1 Then
         p1(n, 2) = 1
      End If
   Next n

   If new_j > 0 Then
      z1(new_j, 2) = 0
   End If
  
   For i = 0 To UBound(p1, 1)
      t_m(i) = 0
   Next i
Next c_t

'Output Location Initialization
Sheets(2).Range("C3:C100").Value = ""
Sheets(2).Range("G3:Z100").Value = ""
Sheets(3).Range("A3:K100").Value = ""

'Output
Dim t As Integer: t = 3 '//Sheets 3 Output Row
Sheets(2).Activate
For j = 1 To UBound(z1, 1)
   k = 1
   For i = 0 To UBound(p1, 1)
      If i = 0 Then
         If d_m(i, j) <> 0 Then
            Sheets(2).Cells(j + 2, 3) = z1(d_m(i, j), 1) + yotyou
         End If
        
      Else
         If d_m(i, j) = 1 Then
         Sheets(2).Cells(j + 2, 6 + k) = d_m(i, j) * p1(i, 1) - kiri
         k = k + 1
         End If
      End If
   Next i
Next j

'/Margin Output
For j = 1 To UBound(z1, 1)
   If z1(j, 2) = 1 Then
      Sheets(3).Cells(t, 4) = z1(j, 1) + yotyou
      t = t + 1
   End If
Next j
If t = 3 Then
   Sheets(3).Cells(t, 4) = "None"
End If

'/Missing Materials Output
t = 3
For j = 1 To UBound(p1, 1)
   If p1(j, 2) = 0 Then
      Sheets(3).Cells(t, 10) = p1(j, 1) - kiri
      t = t + 1
   End If
Next j
If t = 3 Then
   Sheets(3).Cells(t, 10) = "None"
End If



End Sub

Function better(ByRef now_part() As Long, ByRef f_l As Long) As Long()

Dim b_j As Integer                                 '//Parts Counter
Dim b_k As Integer                                 '//Target Length
ReDim f(1 To UBound(now_part), 0 To f_l) As Long   '//Optimal Solution with Minimal Residual
ReDim b(0 To UBound(now_part)) As Long
Dim b_a As Long, b_b As Long
Dim buf As Long, f_c As Long
Dim f_d As Long

For b_j = 1 To UBound(now_part)
   For b_k = 0 To f_l
      If b_j = 1 Then
         If 0 <= b_k And b_k < now_part(1) Then
            f(b_j, b_k) = 0
         ElseIf now_part(1) <= b_k Then
            f(b_j, b_k) = now_part(1)
         End If
      ElseIf b_j >= 2 Then
      
         b_a = f(b_j - 1, b_k)
         If b_k - now_part(b_j) < 0 Then
            b_b = -now_part(b_j)
         Else
            b_b = f(b_j - 1, b_k - now_part(b_j))
         End If
        
         If b_a > b_b + now_part(b_j) Then
            f(b_j, b_k) = b_a
         Else
            f(b_j, b_k) = b_b + now_part(b_j)
         End If
      End If
   Next b_k
Next b_j

buf = f(UBound(now_part), f_l)
f_c = f_l
For b_j = UBound(now_part) To 2 Step -1
   If buf = f(b_j - 1, f_c) Then
      b(b_j) = 0
   Else
      For b_k = f_c To 1 Step -1
         If buf - now_part(b_j) = f(b_j - 1, b_k) And f(b_j - 1, b_k - 1) <> f(b_j - 1, b_k) Then
            b(b_j) = 1
            buf = f(b_j - 1, b_k)
            f_c = b_k
            f_d = f_d + 1
            Exit For
         ElseIf buf = now_part(b_j) And now_part(b_j) <> 0 Then
            b(b_j) = 1
            buf = 0
            f_c = b_k
            f_d = f_d + 1
            Exit For
         End If
      Next b_k
   End If
Next b_j

If buf <> 0 Then
   b(1) = 1
   f_d = f_d + 1
End If

b(0) = (f_l - f(UBound(now_part), f_l)) * f_d
better = b()
End Function

Function exist1(ByRef now_part() As Long) As Long
Dim e_i As Integer
exist1 = 0
For e_i = 1 To UBound(now_part)
   If now_part(e_i) > 0 Then
      exist1 = 1
      Exit For
   End If
Next e_i
End Function