- Xiaomi 13T és 13T Pro - nincs tétlenkedés
- Motorola Edge 40 - jó bőr
- Apple AirPods Pro (2. generáció) - csiszolt almaságok
- Mobil flották
- Samsung Univerzum: Így ismerhető meg a Galaxy AI bármilyen telefonon
- Motorola Edge 40 neo - színre és formára
- Android alkalmazások - szoftver kibeszélő topik
- Motorola Moto G24 Power - hol van az erő?
- Samsung Galaxy S24 - nos, Exynos
- Poco X6 Pro - ötös alá
Hirdetés
-
Dragon Ball: Sparking! Zero - Mester és tanítvány
gp Egyelőre még mindig nem kaptunk megjelenési dátumot a játékhoz.
-
Agyi chipes gyártóba fektetett a kriptocég
it A Tether 200 millió dollárt fektet a Blackrock Neurotech agyi chipes vállalatba.
-
Samsung Univerzum: Így ismerhető meg a Galaxy AI bármilyen telefonon
ma A Try Galaxy webalkalmazás kontrollált környezetben mutatja meg, mit tud a One UI 6.1-es rendszer és a mesterséges intelligencia.
-
Mobilarena
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
-
-
#90999040
törölt tag
válasz
Sziszmisz
#13881
üzenetére
Ezt próbáld ki. De először ne élesben!!!
Sub Modosit()
Application.ScreenUpdating = False
szin = ActiveCell.CurrentRegion.Cells(2, 1).Interior.Color
For Each r In ActiveCell.CurrentRegion.Offset(0, 1).Resize(columnsize:=1)
If r.Interior.Color = szin Then
s = Cells(r.Row, r.Column - 1).Value
Else
r.Value = r.Value & " " & s
End If
Next
Application.ScreenUpdating = True
End SubElindításkor bármelyik cella ki lehet jelölve, csak az a fontos, hogy az adattáblán belül legyen a kijelölés.
-
#90999040
törölt tag
válasz
Sziszmisz
#13891
üzenetére
Igazából a tartomány bárhol lehet, a lényeg:
1: az a munkalap legyen kijelölve, ahol az adatok vannak
2: a kijelölt cella a tartományon belül legyen
3: az előbb említett elrendezés legyen. tehát:
ha pl. a sarokcella : B2(ennek színezetlennek kell lennie!!!), akkor az első színezett cella a B3-ban legyen, és a C oszlopot kell módosítani. Most látom, a sorszámozás oszlopát nem vettem figyelembe. Ez a sorszámozás a táblához tartozik?Egyébként, amik színezve vannak, azok a cellák egyesítettek az eredeti verzióban?
[ Szerkesztve ]
-
#90999040
törölt tag
válasz
Sziszmisz
#13895
üzenetére
Akkor nézd meg ezt. Ebben már benne van a sorszámozás oszlopa is, valamint itt már nem a színezés számít, hanem, hogy üres-e a Terméktípus oszlpa.
Sub Modosit()
Application.ScreenUpdating = False
For Each r In ActiveCell.CurrentRegion.Offset(0, 2).Resize(columnsize:=1)
If r.Value = "" Then
s = Cells(r.Row, r.Column - 1).Value
Else
r.Value = r.Value & " " & s
End If
Next
Application.ScreenUpdating = True
End Sub[ Szerkesztve ]
-
#90999040
törölt tag
válasz
Sziszmisz
#13898
üzenetére
Ha a cikkszám az A oszlopban van, akkor igen.
If r.Value = "" Then -> itt vizsgálom, hogy a B oszlopban a cella üres-e.
Ha egy ilyen üres cellát talál a B oszlopban, akkor annak értékét eltárolja, és egészen addig ezt az értéket adja hozzá a B oszlop nem üres celláihoz, amíg a B oszlopban ismét nem talál üres cellát, akkor ezt tárolja el, és így tovább.
A táblázatnak nem szükséges az A1-ben kezdődnie, kezdődhet akár a D11-ben is....
Az elejére pedig így tudod hozzáfűzni:
r.Value = s & " " & r.Value[ Szerkesztve ]
-
#90999040
törölt tag
válasz
detroitrw
#14023
üzenetére
Megoldani meg lehet, csak kérdés, hogy mennyi idő alatt.
Sima függvényekkel szerintem teljesen kizárt, vba-val lehetséges. De azért gondolj bele:
Úgy látom, hogy 72 darab léc van jelenleg. Ennek a 72 elemnek kell(ene) az ismétlés nélküli permutációja, ami ugye 72! (faktoriális) ez ~~8,50478588567862E+101 eset, azaz kb. 8 a 101-ediken.
Namost ezt ha most elindítod, akkor talán( 
) 1 hét múlva végez.Esetleg azt meg lehetne próbálni, hogy bizonyos hulladékszálakot megadni, és ha ez a százalék elég nagy, akkor van esély, hogy előbb talál egy ezen belülit.
Vagy random generálással is lehetne, szerencsés esetben előbb-utóbb beleakad egy alkalmas lehetőségbe....
-
#90999040
törölt tag
válasz
cousin333
#14029
üzenetére
Igen, ismétléses kell, de abból indultam ki, hogy ahhoz, hogy algoritmus szintjén ki tudd szűrni az ismétlődéseket, ahhoz jó eséllyel le kell generálni az ismétlés nélküli eseteket...
De ha felesleges körök nélkül sikerülne is csak az ismétléseseket egyből eltalálni, még az is 1,7322649796561E+48, szóval iszonyatosan sok, és akkor még nem is vettük figyelembe, hogy ez csak a konkrét példára vonatkozik, ami természetesen még negatív irányba is változhat...De a megoldás nem ilyen bonyolult, mert nem kell ennyi esetet végigvenni
Semennyire sem bonyolult, ha írsz olyan algoritmust, ami elsőre eltalálja a legjobb megoldást, mert ekkor 1 kísérlet bőven elég.
Azon az úton még el lehetne indulni, hogy az adott fix hossz ismeretében csak a lehetséges megoldásokat figyelembe venni. Ez az algoritmus viszonylag gyorsan lefut(kb. 1 másodperc sem), de a gondok utána jönnek. Ugyanis ezekkel az adatokkal a lehetséges esetek száma 1048. Ebből 238 olyan, amelyekre még a legrövidebb szál sem férne rá pluszban a 6 méterre. Ha biztosra kellene menni, akkor a következő eseteket kellene vizsgálni:
N K
1048 19
1048 20
1048 21
..... és még ki tudja meddig???mert a hosszokból az következik, hogy elvileg 19 darab 6 méteresnek elégnek kellene lennie(elméletileg). Azért több K-ra, mert egyáltalán nem biztos, hogy a valóságban is elég a 19 szál(mi van, ha pl. csak 23 szál a legkedvezőbb???). Ha az 1048 helyett a 238-al(tehát csak azokkal foglalkozunk, amire több már biztos, hogy nem fér rá), még akkor is elég sok esetnél tartunk...
-
#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 ]
-
#90999040
törölt tag
válasz
detroitrw
#14038
üzenetére
Szerintem nem annyira értelmezhetetlen.
Egy sor -> egy szálat jelent. Pl. a fejléc a konkrét esetben:
2427 2359 946 900 430 410 Hulladék Teljes Max darab
Az egyik sor pedig:
0 0 0 2 5 5 0 * 1
Ez ezt jelenti egy szál esetén:
0*2427 + 0*2359 + 0*946 + 2*900 + 5*430 + 5*410 = 6000Értelemszerűen a hulladék 0%. Teljes oszlopban a * azt jelenti, hogy erre a szálra már a legrövidebb(410 mm-es) darab sem férne rá.
A max darab ebből a szálból azért 1, mert ha pl. 2 lenne, akkor már a 430 mm-esből 10 darab jönne ki, holott összesen csak 6 darab kell belőle.Az adott linken levő programot fogalmam nincs, hogy lehetne működésre bírni(már csak azért sem, mert amit meg tudok csinálni, abból a legritkább esetben használok kész programot). De más talán majd megnézi...
Viszont még az elején említettem a random generálást. Ezt kipróbáltam. Ha 20 szálra keresek, akkor nagyon rövid idő alatt kidob egy lehetséges megoldást. Ha erre lecseréled az előző makrót, akkor láthatod az eredményt.
Sub frissit()
Set cel = Range("D1")
Range("D1:V" & Rows.Count).ClearContents
korrekcio = 1
maxprobalkozas = 10000000
talalatszam = 0
sor = cel.Row
oszlop = cel.Column
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
hosszok = Application.Transpose(Range("A2:A7"))
szalhossza = Range("A10").Value
darabok = Application.Transpose(Range("B2:B7"))
osszdarab = 0
osszhossz = 0
For i = 1 To UBound(darabok)
osszdarab = osszdarab + darabok(i)
osszhossz = osszhossz + hosszok(i) * darabok(i)
Next
mindarab = Application.RoundUp(osszhossz / szalhossza, 0)
ReDim tomb(0 To osszdarab - 1)
aktindex = 0
For i = 1 To UBound(darabok)
For j = 0 To darabok(i) - 1
tomb(aktindex) = hosszok(i)
aktindex = aktindex + 1
Next
Next
'kezdődik a tippözön :)
Randomize
For i = 1 To maxprobalkozas
For j = 0 To UBound(tomb)
R = Int((osszdarab) * Rnd())
R1 = Int((osszdarab) * Rnd())
If R <> R1 Then
temp = tomb(R)
tomb(R) = tomb(R1)
tomb(R1) = temp
End If
Next
szalakszama = 0
akthossz = 0
temphossz = 0
For j = 0 To UBound(tomb)
If akthossz + tomb(j) = szalhossza Then
temphossz = temphossz + akthossz + tomb(j)
akthossz = 0
szalakszama = szalakszama + 1
ElseIf akthossz + tomb(j) > szalhossza Then
temphossz = temphossz + akthossz
akthossz = tomb(j)
szalakszama = szalakszama + 1
Else
akthossz = akthossz + tomb(j)
End If
Next
If temphossz < osszhossz Then szalakszama = szalakszama + 1
If szalakszama <= mindarab + korrekcio Then
talalatszam = talalatszam + 1
akthossz = 0
aktoszlop = oszlop
s = ""
For j = 0 To UBound(tomb)
If akthossz + tomb(j) = szalhossza Then
akthossz = 0
Cells(sor, aktoszlop) = tomb(j)
sor = sor + 1
aktoszlop = oszlop
ElseIf akthossz + tomb(j) > szalhossza Then
akthossz = tomb(j)
sor = sor + 1
aktoszlop = oszlop
Cells(sor, aktoszlop) = tomb(j)
aktoszlop = aktoszlop + 1
ElseIf j = UBound(tomb) Then
Cells(sor, aktoszlop) = tomb(j)
aktoszlop = aktoszlop + 1
Else
Cells(sor, aktoszlop) = tomb(j)
aktoszlop = aktoszlop + 1
akthossz = akthossz + tomb(j)
End If
Next
sor = cel.Row + talalatszam * (mindarab + korrekcio + 1)
aktoszlop = oszlop
Exit Sub
End If
Next
End SubAz elején a korrekcio = 1 állítja be, hogy nem az elméleti minimális szálmennyiségre akarunk keresni, hanem 1-el többre(jelen esetben 20-ra).
Nálam ez nagyon gyorsan beleszalad egy lehetőségbe.
Persze még van rajt bőven finomítanivaló, de ezek már csak részletkérdések. A Exit sub miatt kilép az első találat után, ha ez nincs benne, akkor többet is keres, egészen a maxprobalkozas-ig. Valószínűleg nincs szükség annyi random számra, amennyi a tomb elemeinek a száma->ezt ki lehet tapasztalni... -
#90999040
törölt tag
válasz
hallgat
#14093
üzenetére
Próbáld meg így:
n = Range("A" & Rows.Count).End(xlUp).Row
For i = n - 1 To 1 Step -1
If Cells(i, 1).Value <> Cells(n, 1).Value Then
If i < n - 1 Then Rows(i + 1 & ":" & n - 1).Delete
n = i
End If
Next
If Cells(1, 1).Value = Cells(n, 1).Value And n > 1 Then Rows(1 & ":" & n - 1).Delete -
#90999040
törölt tag
válasz
hallgat
#14111
üzenetére
Azért annyi, mert a cellából/ba olvasás/írás nagyon lassú művelet.
Ha viszont a memóriába olvasod be "tömbként", azon sokkal gyorsabb maga a művelet sebessége, viszont így a memóriahasználat sokkal nagyobb. De hát ugye valamit valamiért.
Még lehetne úgy is, hogy a táblázathoz egy plusz oszlopot átmenetileg hozzáadni, ebben megjelölni a megmaradó cellákat, majd sorba rendezni. Ezután megkeresni ebben az új oszlopban az első nem üres cellát, majd a táblázat sorainak a celláit innentől kezdve törölni. Majd a végén az új oszlop celláit is törölni:
Application.ScreenUpdating = False
Set elsoadat = Range("A2")
Set rng = elsoadat.CurrentRegion
If rng.Row < elsoadat.Row Then Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count)
n = Cells(Rows.Count, rng.Column).End(xlUp).Row
tomb = Application.Transpose(Range(Cells(rng.Row, rng.Column), Cells(n, rng.Column)).Value)
ReDim tomb1(1 To UBound(tomb))
n = UBound(tomb)
tomb1(n) = 1
For i = n - 1 To 1 Step -1
If tomb(i) <> tomb(n) Then
tomb1(i) = 1
n = i
End If
Next
n = UBound(tomb)
Range(Cells(rng.Row, rng(rng.Count).Column + 1), Cells(rng(rng.Count).Row, rng(rng.Count).Column + 1)).Value = Application.Transpose(tomb1)
Range(Cells(rng.Row, rng.Column), Cells(rng.Row + n - 1, rng(rng.Count).Column + 1)).Sort Key1:=Cells(rng.Row, rng(rng.Count).Column + 1), Order1:=xlDescending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
m = Cells(Rows.Count, rng(rng.Count).Column + 1).End(xlUp).Row
Range(Cells(m + 1, rng.Column), Cells(rng.Row + n - 1, rng(rng.Count).Column + 1)).Delete
Range(Cells(rng.Row, rng(rng.Count).Column + 1), Cells(m, rng(rng.Count).Column + 1)).Delete
Set rng = ActiveSheet.UsedRange
Application.ScreenUpdating = TrueItt a elsoadat-ban kell megadni az első olyan adatot tartalmazó cellát, amelytől lefelé az ismétlődéseket figyelni kell. Előnye, hogy csak egy oszlopot ír(bár 2-t olvas be, valamint autómatikusan érzékeli a fejlécet is, ha a elsoadat jól van megadva, tehát a táblázat igazából bárhol lehet, nem csak az A2-ben.
Namost ezt ha most elindítod, akkor talán( 
) 1 hét múlva végez.
Új hozzászólás Aktív témák
Delila_1- Luck Dragon: Asszociációs játék. :)
- Suzuki topik
- AMD Ryzen 9 / 7 / 5 7***(X) "Zen 4" (AM5)
- Xiaomi 13T és 13T Pro - nincs tétlenkedés
- Milyen cserélhető objektíves gépet?
- Milyen routert?
- Motorola Edge 40 - jó bőr
- ZIDOO médialejátszók
- Kerékpárosok, bringások ide!
- Békéscsaba és környéke adok-veszek-beszélgetek
- További aktív témák...
- Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Windows 10/11 Home/Pro , Office OEM/Retail kulcsok
- Adobe Creative Cloud - 2024. 04. 05 - 2025. 04. 05-ig
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.