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

• #26468 Delila_1 veterán Sanki #26461

  Új Válasz 2015-04-08 13:32:53 #26468

  Ú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

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Sanki #26461 üzenetére

  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

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