-
Fototrend
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
cousin333
addikt
válasz detroitrw #14032 üzenetére
A sokféle lehetséges variáció miatt nem elhanyagolható a kézi módszer.
Én készítettem egy gépi változatot, ami a Solver funkcióra alapoz, és brute-force módszert használ: [link].
Persze igyekeztem minimalizálni a lehetőségeket számos korlátozás bevezetésével. Mindenesetre nálam gond nélkül futott egy órát, és még nem adott végleges eredményt. Igazából nem tudom, meddig futna...
Az egyes cellákat kicsit nehéz kibogarászni, mert a lehető legtöbb konkrét számot és a legkevesebb képletet szerettem volna felhasználni, így remélve azt, hogy gyorsul a számolgatás.
A lényeg, hogy az egyes sorokban látod a különböző elosztási típusokat (max. 5-öt), ahogy te is csináltad a kézi módszernél. A rendszer azt számítja, hogy melyik hosszból mennyit használjon, illetve az adott osztást hány lécen alkalmazza.
A Solver a maradék hosszok négyzetösszegét igyekszik minimalizálni, ami nem feltétlenül a legoptimálisabb cél, de talán nem okoz olyan nagy hibát.
[ Szerkesztve ]
"We spared no expense"
-
#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 SubA 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.
[ Szerkesztve ]
Új hozzászólás Aktív témák
- PC JÁTÉKOK (OLCSÓ STEAM, EA , UPLAY KULCSOK ÉS SOKMINDEN MÁS IS 100% GARANCIA )
- Magix Acid Pro 11 zenei szoftver
- Windows 10/11 Home/Pro , Office OEM/Retail kulcsok
- Eredeti Windows, telepítéssel! Digital Doctor Számítógép Szerviz
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! LEGOLCSÓBB! Automatikus 0-24
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen
Cég: Promenade Publishing House Kft.
Város: Budapest