Kopírování "jmen" pod sebe dle daného počtu Vyřešeno

[saabturboclub]

Ahoj,
potřeboval bych poradit, jak v excelu (VB) udělám následovné: př: oblast B2:B13 bude obsahovat přítomné lidi v práci (max. 11lidí) s tím, že počet se liší podle docházky, může bát jen 5 lidí z určené oblasti. V další záložce bych měl sloupec obsahující čísla úkolů pod sebou (třeba 500řádků). A potřeboval bych aby se jména z vybrané oblasti (ted jich je třeba jen 5) se nakopírovala vedle čísla úkolu začínající od prvního řádku a vybrané jména se budou pod sebou opakovat podle zadaného počtu v nějaké bunce (třeba 12 = jméno se bude max. 12x opakovat = člověk dostane 12 čísel úkolů)-.

nemůžu přijít na to, jak zadat dle určitého počtu kopírování pod sebe, někdy může být 11jmen a každé dostane 20 úkolů...

Díky za radu, Pavel

[Reklama]

[navstevnik]

Procedura resici pozadovane, (v edotoru VBA vlozit do standardniho modulu, volat klavesovou zkratkou nebo z menu):

Kód: Vybrat vše

Option Explicit

Sub PrirazeniPracovniku()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, Opakovat As Byte, OfsR As Integer

  ' deklarovat blok seznamu pracovniku a nacist pocet opakovani
  With Worksheets("list1")
    Set SBlk = .Range(.Range("b2"), .Range("b2").End(xlDown))
    If SBlk.Rows.Count > 11 Then MsgBox "Seznam pracovniku je prazdny": GoTo ErrExit
    If Not IsNumeric(.Range("g2").Value) Then MsgBox "Chyba v zadani poctu opakovani": GoTo ErrExit
    Opakovat = Int(.Range("g2").Value)
  End With
  Set TCll = Worksheets("data").Range("b2")
  ' ve smycce vlozit opakovane jmena na list Data
  OfsR = 0
  Do While Opakovat > 0
    For Each SCll In SBlk.Cells
      TCll.Offset(OfsR, 0).Value = SCll.Value
      OfsR = OfsR + 1
    Next SCll
    Opakovat = Opakovat - 1
  Loop
  Set TCll = Nothing
  Set SCll = Nothing
ErrExit:
  Set SBlk = Nothing
End Sub

PS.: Je mozno doplnit preneseni oznacenych jmen z listu dochazka na list1 pouzitim funkci listu.
mozne reseni je v priloze: