VBa - kopírování podle parametru 2 Vyřešeno

[WikisRuleZz]

Dobrý den,

nedávno jste mi radili s kopírováním podle parametru.

For i = 1 To Cells(1, 2)
Cells(i, 3) = Cells(1, 1) '* Cells(1, 2)
Next i

Jak bylo řečeno tento cyklus vytvoří v buňce C1 tolik buněk s textem z A1 kolikrát je zadáno v buňce B1. Já se to snažím rozšířit aby oblast byla libovolně veliká. Tedy aby se kopírování neomezovalo jen na Buňky A1. Ať se pokouším jak se pokouším, tak pomocí xl(down) se mi ověří velikost tabulky v A a v B ale zkopíruje se poslední jen a já potřebuji aby pod sebou byly všechny záznamy.

[Reklama]

[navstevnik]

Zkus tuto proceduru, kopiruje hodnoty (pro predpokladane opakovani v radu jednotek neni vlozena kontrola prekroceni limitu radku (sloupcu) listu):

Kód: Vybrat vše

Option Explicit

Sub KopirovatNkrat()
  Dim SBlk As Range  ' blok ke kopirovani
  Dim SBlkR As Integer, SBlkC As Integer ' radky, sloupce
  Dim NKrat As Integer  ' pocet kopirovani
  Dim TCll As Range  ' cilova bunka pro umisteni leve horni bunky prvni kopie
  Dim i As Integer, OfsR As Long, OfsC As Integer
  With ActiveSheet
    Set SBlk = .Range("a1:b2")  ' definice zdrojoveho bloku
    With SBlk  ' pocet radku a sloupcu kopirovaneho bloku
      SBlkR = .Rows.Count
      SBlkC = .Columns.Count
    End With
    NKrat = .Range("G1").Value  ' nacist pocet opakovani
    Set TCll = .Range("j5")  ' definice cilove bunky
    ' nastaveni ofsetu radku a sloupcu pro opakovane umisteni, vyber dle potreby
    ' pod sebou:
'    OfsR = SBlkR
'    OfsC = 0
    'vedle sebe:
    OfsR = 0
    OfsC = SBlkC
    ' kaskadovite
'    OfsR = SBlkR
'    OfsC = SBlkC
    For i = 0 To NKrat - 1
      TCll.Resize(SBlkR, SBlkC).Offset((i * OfsR) - 1, (i * OfsC) - 1).Value = SBlk.Value
    Next i
  End With
  ' odstranit objektove promenne
  Set SBlk = Nothing
  Set TCll = Nothing
End Sub

[WikisRuleZz]

Čekal jsem něco jednoduššího. Můžu se ještě zeptat jak to funguje. Ať na to koukám a zkouším jak chci tak mi to nechce chodit...Děkuji za ochotu.

[navstevnik]

Vzhledem k tomu, ze z:

Já se to snažím rozšířit aby oblast byla libovolně veliká. Tedy aby se kopírování neomezovalo jen na Buňky A1.

nelze vycist nez, ze potrebujes kopirovat nejaky blok bunek (a z predchozihi opakovane kopirovat), prilozil jsem proceduru univerzalnejsiho charakteru.
Na aktivnim listu je oblast bunek urcena k nasobnemu kopirovani - v procedure zadat blok bunek do:
Set SBlk = .Range("a1:b2") ' definice zdrojoveho bloku
Na aktivnim listu je bunka obsahujici nasobek kopirovani - v procedure zadat bunku do:
NKrat = .Range("G1").Value ' nacist pocet opakovani
V procedure zadat bunku pro umisteni leve horni bunky prvni kopie:
Set TCll = .Range("j5") ' definice cilove bunky
Dale je v procedure podle zpusobu rozmisteni kopirovanych bloku (pod sebou, vedle sebe, kaskadovite) potreba aktivovat/deaktivovat dva radky obsahujici prislusne ofsety:
OfsR = ...
OfsC = ...
Proceduru je nutno umistit v editoru VBA(volat z Excelu Alt+F11) do standardniho modulu, upravit vyse uvedene, a spustit v editoru VBA klavesou F5 nebo z Excelu z menu/pasu karet dle verze Excelu.
Neni osetren nekorektni stav - nezadany pocet opakovani, pripadne hodnota 0.