Új hozzászólás Aktív témák

• #14036 #90999040 törölt tag detroitrw #14032

  Új Válasz 2012-06-19 09:52:35 #14036

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  

  #90999040

  törölt tag

  válasz detroitrw #14032 üzenetére

  Egy új munkalapra másold át az A1 : B7 tartományt(hogy az új munkalapon is az A1 : B7-ben legyen. Az A10-be írd be a 6000-et(mert milliméterben számol).
  ALT+F11, majd INSERT menü -> Module.
  Ebbe a modulba másold be ezt:

  Sub frissit()
  Set cel = Range("D1")
  maxsordarab = 20000
  sor = 1 + cel.Row
  oszlop = cel.Column
  eredetisor = sor
  
  Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
  hosszok = Application.Transpose(Range("A2:A7"))
  szalhossza = Range("A10").Value
  darabok = Application.Transpose(Range("B2:B7"))
  vegsodarabok = Application.Transpose(Range("B2:B7"))
  For i = LBound(vegsodarabok) To UBound(vegsodarabok)
  vegsodarabok(i) = Application.Min(Application.RoundDown(szalhossza / hosszok(i), 0), darabok(i))
  Next
  
  ReDim kimenet(1 To maxsordarab, 1 To 9)
  ossz = 0
  osszeg = 0
  teljes = 0
  n = UBound(darabok) - 1
  ReDim tomb0(0 To n)
  q = -1
  Do
  While q < n
  q = q + 1
  tomb0(q) = 0
  Wend
  ossz = ossz + 1
  
  tele = True
  m = 0
  For i = 0 To n
  If tomb0(i) < darabok(i + 1) Then
  If osszeg + hosszok(i + 1) <= szalhossza Then
  tele = False
  Exit For
  End If
  End If
  Next
  If tele Then teljes = teljes + 1
  Dim maxdarab As Integer
  maxdarab = 200
  If tele Then
  For i = 0 To UBound(tomb0)
  m = m + hosszok(i + 1) * tomb0(i)
  kimenet(1 + sor - eredetisor, 1 + i) = tomb0(i)
  
  If tomb0(i) <> 0 Then
  If Application.RoundDown(darabok(i + 1) / tomb0(i), 0) < maxdarab Then maxdarab = Application.RoundDown(darabok(i + 1) / tomb0(i), 0)
  End If
  Next
  kimenet(1 + sor - eredetisor, 1 + i) = (szalhossza - m) / szalhossza
  kimenet(1 + sor - eredetisor, 1 + i + 1) = "*"
  kimenet(1 + sor - eredetisor, 1 + i + 2) = maxdarab
  sor = sor + 1
  Else
  For i = 0 To UBound(tomb0)
  m = m + hosszok(i + 1) * tomb0(i)
  kimenet(1 + sor - eredetisor, 1 + i) = tomb0(i)
  
  If tomb0(i) <> 0 Then
  If Application.RoundDown(darabok(i + 1) / tomb0(i), 0) < maxdarab Then maxdarab = Application.RoundDown(darabok(i + 1) / tomb0(i), 0)
  End If
  Next
  kimenet(1 + sor - eredetisor, 1 + i) = (szalhossza - m) / szalhossza
  kimenet(1 + sor - eredetisor, 1 + i + 2) = maxdarab
  sor = sor + 1
  End If
  
  Do While q > -1
  If tomb0(q) < vegsodarabok(q + 1) Then
  tomb0(q) = tomb0(q) + 1
  osszeg = osszeg + hosszok(q + 1)
  If osszeg > szalhossza Then
  osszeg = osszeg - hosszok(q + 1)
  tomb0(q) = tomb0(q) - 1
  osszeg = osszeg - hosszok(q + 1) * tomb0(q)
  q = q - 1
  Else
  Exit Do
  End If
  Else
  osszeg = osszeg - hosszok(q + 1) * tomb0(q)
  q = q - 1
  End If
  Loop
  Loop While q > -1
  sor = sor - 1
  For i = 1 To 9
  kimenet(1, i) = kimenet(1 + sor - eredetisor, i)
  kimenet(1 + sor - eredetisor, i) = ""
  Next
  
  ActiveWindow.FreezePanes = False
  Range(Cells(eredetisor - 1, oszlop), Cells(maxsordarab, oszlop + 8)).ClearContents
  Range(Cells(eredetisor, oszlop), Cells(eredetisor + maxsordarab - 1, oszlop + 8)).Value = kimenet
  Range(Cells(eredetisor - 1, oszlop), Cells(eredetisor - 1, oszlop + 5)).Value = Application.Transpose(Range("a2:a7").Value)
  Cells(eredetisor - 1, oszlop + 6).Value = "Hulladék"
  Cells(eredetisor - 1, oszlop + 7).Value = "Teljes"
  Cells(eredetisor - 1, oszlop + 8).Value = "Max darab"
  Cells(eredetisor, oszlop).CurrentRegion.Sort Key1:=Cells(eredetisor, oszlop + 6), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
  
  Cells(eredetisor, oszlop + 10).FormulaR1C1 = "=1+RC[-2]"
  Cells(eredetisor + 1, oszlop + 10).FormulaR1C1 = "=(1+RC[-2])*R[-1]C"
  Cells(eredetisor + 1, oszlop + 10).Copy Destination:=Range(Cells(eredetisor + 2, oszlop + 10), Cells(sor, oszlop + 10))
  
  Cells(eredetisor, 1).Select
  ActiveWindow.FreezePanes = True
  End Sub

  A makró elindítása után(itt arra figyelni kell, hogy az új munkalap legyen az aktív) a D:H oszlopokban megjelennek a darabszámok(a fejléc a hosszt tartalmazza). A J oszlopban a hulladék, a K oszlopban levő csillag azt jelenti, hogy az adott 6m-es szálra már a legkisebb(jelen esetben 410 mm-es) darab sem fér rá.
  Az L oszlopban az adott szál maximális darabszáma szerepel.

  A legfontosabb: N oszlopban jelzi, hogy hány esetet kellene megvizsgálni - no ez az, ami miatt napok/hetek/évek kérdése, hogy mikor végezne az összes eset megvizsgálásával.

Új hozzászólás Aktív témák