-
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
-
Delila_1
veterán
-
Delila_1
veterán
Most tetszőleges név, és tetszőleges terület esetén is elkészíti a beosztást. Nincs benne viszont, hogy minden terület legalább 1× szerepeljen. Nem minden esetben van megfelelő megoldás, pl. ha sok az eszkimó (ember), és kevés a fóka (terület).
Sub Terulet()
Dim sor As Integer, oszlop As Integer, vel As Integer, i As Integer, soruj As Integer
Dim NevUsor As Long, TerUsor As Long
Dim tomb()
NevUsor = Range("A" & Rows.Count).End(xlUp).Row
TerUsor = Range("G" & Rows.Count).End(xlUp).Row
ReDim tomb(1 To TerUsor)
Application.ScreenUpdating = False
Range("B4:E" & NevUsor) = ""
For sor = 4 To NevUsor
UjSor:
For oszlop = 2 To 5
UJRA:
Randomize
vel = Round(Rnd() * (TerUsor - 3) + 3, 0) '
If tomb(vel) > 0 Then GoTo UJRA ' Ha volt már a sorszám, akkor újra generál
tomb(vel) = 1
Next
oszlop = 2
For i = 1 To TerUsor 'Beírja a területet, lenullázza a tömböt
If tomb(i) = 1 Then
Cells(sor, oszlop) = Cells(i, "G")
oszlop = oszlop + 1
End If
tomb(i) = 0
Next i
For soruj = 3 To TerUsor 'Van-e 3× a terület?
If Application.CountIf(Range("$B$4:$E" & NevUsor), Range("G" & soruj)) > 3 Then
Range("B" & sor & ":E" & sor) = ""
For i = 1 To TerUsor
tomb(i) = 0
Next
GoTo UjSor
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
A makró összeállítja a területek kiosztását.
Sub Terulet()
Dim sor As Integer, oszlop As Integer, vel As Integer, i As Integer, soruj As Integer
Dim tomb(1 To 36) As Integer
Application.ScreenUpdating = False
Range("B4:E23") = ""
For sor = 4 To 23
UjSor:
For oszlop = 2 To 5
UJRA:
Randomize
vel = Round(Rnd() * 33 + 3, 0) '3 és 36 közötti véletlenszámot ad
If tomb(vel) > 0 Then GoTo UJRA ' Ha volt már a sorszám, akkor újra generál
tomb(vel) = 1
Next
oszlop = 2
For i = 1 To 36 'Beírja a területet, lenullázza a tömböt
If tomb(i) = 1 Then
Cells(sor, oszlop) = Cells(i, "G")
oszlop = oszlop + 1
End If
tomb(i) = 0
Next i
For soruj = 3 To 36 'Van-e 3× a terület?
If Application.CountIf(Range("$B$4:$E$23"), Range("G" & soruj)) > 3 Then
Range("B" & sor & ":E" & sor) = ""
For i = 1 To 36
tomb(i) = 0
Next
GoTo UjSor
Exit For
End If
Next
Next
Application.ScreenUpdating = True
End Sub -
hhheni
tag
ez mindig azt a sorrendet fogja adni, ahogyan g3-tól kezdve vannak
ha ez is szempont, akkor a h oszlopban mellé teszel vél() függvénnyel egy oszlopot, és havonta rendezed
persze, lehetnek még finomító kívánságok, pl.:
1. a 34 területből ne minden hónapban legyenek ugyanazok 3-szor ill. 2-szer,
2. egy héten belül ne kerüljön sorra 2* ugyanaz a terület stb. -
hhheni
tag
Új hozzászólás Aktív témák
Hirdetés
- Milyen okostelefont vegyek?
- OLED monitor topic
- sziku69: Szólánc.
- Sorozatok
- Battlefield 6
- AMD K6-III, és minden ami RETRO - Oldschool tuning
- AMD Ryzen 9 / 7 / 5 7***(X) "Zen 4" (AM5)
- Hardcore pizza és kenyér topik
- Luck Dragon: Asszociációs játék. :)
- sziku69: Fűzzük össze a szavakat :)
- További aktív témák...
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- PC Game Pass előfizetés
- Bitdefender Total Security 3év/3eszköz! - Tökéletes védelem, Most kedvező áron!
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- DELL Precision 7730 i5-8400H Quadro P3200 16GB 512GB FHD 17 1 év garancia
- iKing.Hu - Motorola Razr 50 Ultra Midnight Blue Használt, karcmentes állapotban 12 GB RAM / 512 GB
- iPhone 16 128GB Black -1 ÉV GARANCIA - Kártyafüggetlen, MS3096, 97% Akkumulátor
- HIBÁTLAN iPhone 15 Pro Max 256GB Natura Titanium -1 ÉV GARANCIA - Kártyafüggetlen, MS3008, 97% Akksi
- Konzol felvásárlás!! Playstation 5, Playstation 5 Pro
Állásajánlatok
Cég: FOTC
Város: Budapest