VBa - kopírování buněk

[Karel.Houska]

hezký večer, tady na foru jsem se docetl o kopirovani bunek podle "parametru" tady: viewtopic.php?f=35&t=63057

slo by to upravit aby to vypadalo takto jako v prilozenem dokumentu?

Vim, ze to sem nepatri, ale vypada to ,ze vase forum je jedno z tech nejlepsi kde jsem zatim byl...

[Reklama]

[Branscombe]

Vím že návštěvník by to jistě napsal lépe, ale jsem rád že v dnešní době už díky němu zvládám sám napsat takovéto jednoduché zápisy...

Tady je má amatérská verze řešení:

Do standartního modulu vlož:

Kód: Vybrat vše

Sub rozkopirovat()

Dim oblast As Range, text_Cll As Range, pocet As Range, posledni_zaznam As Range

Set oblast = Worksheets("List1").Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set posledni_zaznam = Range("C1")

For Each text_Cll In oblast
Set pocet = text_Cll.Offset(0, 1)
    For i = 1 To pocet
        posledni_zaznam.Value = text_Cll
        Set posledni_zaznam = posledni_zaznam.Offset(1, 0)
    Next i
Next

End Sub


[navstevnik]

Procedura se da napsat jednoduseji (zvlaste pro vetsi pocet opakovani je rychlejsi):

Kód: Vybrat vše

Option Explicit

Sub KopirovatNkrat()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OffsR As Long
  ' definovat promenne
  With Worksheets("list1")
    Set SBlk = .Range("a1:a" & .Cells(.Rows.Count, "a").End(xlUp).Row)
    Set TCll = .Range("c1")
  End With
  ' vykonna smycka
  OffsR = 0  ' vychozi offset ciloveho bloku.
  For Each SCll In SBlk.Cells
    With SCll
      If IsNumeric(.Offset(0, 1).Value) Then  ' je cislo?
        ' definovat cilovy blok podle poctu v Bxx a vyplnit podle Axx
        TCll.Resize(.Offset(0, 1).Value, 1).Offset(OffsR, 0).Value = .Value
        ' offset pro novy cilovy blok
        OffsR = OffsR + .Offset(0, 1).Value
      End If
    End With
  Next SCll
  ' odstranit objektove promenne
  Set SCll = Nothing
  Set SBlk = Nothing
  Set TCll = Nothing
End Sub

V pripade, ze v Bxx neni cislo, neni obsah z Axx kopirovan, neni osetren pripad prekroceni poctu radku na listu.

[Karel.Houska]

Jo tak to jsem si myslel, ze to bude jednodussi. Jeste mam otazku. Kde v tom kodu je urceno "pocet kopirovani" tim myslim ten sloupec B... a jeste se chci zeptat jak zmenit kod kdyz je text z sloupce B misto A pocet kopirovani je v bunce G a misto pro zkoopirovani vysledku je v bunce J?

[navstevnik]

Postupne:

Kde v tom kodu je urceno "pocet kopirovani" tim myslim ten sloupec B

- je to hodnota obsazena v bunce s ofsetem sloupce .Offset(0, 1).Value oproti bunce s kopirovanou hodnotu (Axx).
- uprava pro novy pozadavek - kopirovany text je v B:B, pocet opakovani je v G:G a vysledek do soupce J:J je zde (rozsiren popis kodu, uprava kodu):

Kód: Vybrat vše

Option Explicit

Sub KopirovatNkrat()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OffsR As Long
  Dim OffsCllN As Integer, N As Variant
  ' definovat promenne
  With Worksheets("list1")
    ' zdrojovy blok - texty
    Set SBlk = .Range("b1:b" & .Cells(.Rows.Count, "b").End(xlUp).Row)
    ' vychozi cilova bunka
    Set TCll = .Range("j1")
    ' ofset bunky poctu opakovani oproti text
    OffsCllN = .Range("g1").Column - .Range("b1").Column
  End With
  ' vykonna smycka
  OffsR = 0  ' vychozi offset ciloveho bloku.
  For Each SCll In SBlk.Cells
    With SCll
      N = .Offset(0, OffsCllN).Value  ' pocet opakovani
      If OffsR + N <= Worksheets("list1").Rows.Count Then ' prekrocen pocet radku listu?
        If IsNumeric(N) Then  ' je cislo?
          ' definovat cilovy blok (metoda Resize() a vlastnost Offset() )
          ' podle poctu opakovani N a vyplnit podle SBlk(xx)
          TCll.Resize(N, 1).Offset(OffsR, 0).Value = .Value
          ' novy offset pro dalsi cilovy blok
          OffsR = OffsR + N
        End If
      Else
        MsgBox "Prekrocen pocet radku listu", vbOKOnly + vbExclamation
        Exit For
      End If
    End With
  Next SCll
  ' odstranit objektove promenne
  Set SCll = Nothing
  Set SBlk = Nothing
  Set TCll = Nothing
End Sub

PS.: Pokud mas dojem, ze to neni jednodusi, tak je to dano poznamkami, kontrolou na prekroceni poctu radku listu, overenim na cislo ve sloupci poctu opakovani, odstraneni objektovych promennych z pameti; jinak je kod pro velke pocty opakovani podstatne rychlejsi

[Karel.Houska]

děkuji za vysvetlivky, rozhodne je to srozumitelnejsi nez jen kod.

jen posledni otazku jestli jsem pochopil spravne to s tim urcovani bunek podle kterych se bude kopirovat a kam.

pokud by treba kopirovani probihalo az od sedmeho radku, pak..

..staci jen

Set SBlk = .Range("b7:b" & .Cells(.Rows.Count, "b").End(xlUp).Row)
' vychozi cilova bunka
Set TCll = .Range("j7")
' ofset bunky poctu opakovani oproti text
OffsCllN = .Range("g7").Column - .Range("b7").Column

a

TCll.Resize(N, 1).Offset(OffsR, 0).Value = .Value

pochopil jsem to spravne? Protoze me to pak vyhazuje chybu:Appkication-defined or objectt-defined error (Run.time error 1004)

Jeste jsem slysel, ze pry novy excel ma nekolik miliard radku, takze ta kontrola je pro stare excely?

[navstevnik]

staci jen jak uvadis:
...
' zdrojovy blok - texty
Set SBlk = .Range("b7:b" & .Cells(.Rows.Count, "b").End(xlUp).Row)
' vychozi cilova bunka
Set TCll = .Range("j7")
...
muze zustat beze zmeny:
...
' ofset bunky poctu opakovani oproti text
OffsCllN = .Range("g1").Column - .Range("b1").Column
...
protoze je definovan pouze odstup sloupcu

Jina uprava jiz neni potrebna.
Pokud uvadis, ze vznikla chyba napr.: Run.time error 1004, pak je zapotrebi uvest, i ve kterem radku procedury.

Excel 2007-10 ma na listu pouze 1 048 576 radku. Pokud by vychozi posun ve sloupci B:B byl vyznamny ve vztahu k celkovemu poctu kopii, pak by bylo zapotrebi tento vychozi posun zahrnout do kontroly poctu kopirovanych radku.
Kdyby byl celkovy pocet kopirovanych radku <65 536, neni kontrola potrebna ani pro Excel 2000-03, pro verzi Excel 97 by kontrola byla na pocet raku 16 384.

[Karel.Houska]

Tady v tom řádku mi to nahlásilo chybu když jsem udělal to co jsem psal před tím.

" TCll.Resize(N, 1).Offset(OffsR, 0).Value = .Value "

takhle jsem to tedy napsal. Ne že by to mělo nějaký význam, ale jen se chci ujistit, že jsem pochopil tu proceduru správně.

Kód: Vybrat vše

Option Explicit

Sub KopirovatNkrat()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OffsR As Long
  Dim OffsCllN As Integer, N As Variant
  ' definovat promenne
  With Worksheets("January")
    ' zdrojovy blok - texty
    Set SBlk = .Range("b7:b" & .Cells(.Rows.Count, "b").End(xlUp).Row)
    ' vychozi cilova bunka
    Set TCll = .Range("j7")
    ' ofset bunky poctu opakovani oproti text
    OffsCllN = .Range("g1").Column - .Range("b1").Column
  End With
  ' vykonna smycka
  OffsR = 0  ' vychozi offset ciloveho bloku.
  For Each SCll In SBlk.Cells
    With SCll
      N = .Offset(0, OffsCllN).Value  ' pocet opakovani
      If OffsR + N <= Worksheets("January").Rows.Count Then ' prekrocen pocet radku listu?
        If IsNumeric(N) Then  ' je cislo?
          ' definovat cilovy blok (metoda Resize() a vlastnost Offset() )
          ' podle poctu opakovani N a vyplnit podle SBlk(xx)
            TCll.Resize(N, 1).Offset(OffsR, 0).Value = .Value
          ' novy offset pro dalsi cilovy blok
          OffsR = OffsR + N
        End If
      Else
        MsgBox "Prekrocen pocet radku listu", vbOKOnly + vbExclamation
        Exit For
      End If
    End With
  Next SCll
  ' odstranit objektove promenne
  Set SCll = Nothing
  Set SBlk = Nothing
  Set TCll = Nothing
End Sub

[navstevnik]

U procedury, kterou jsi nyni prilozil, neni duvod ke vzniku chyboveho hlaseni, pokud bunka poctu opakovani neni prazdna.
Kdyz uz osetrovat chyby, tak je procedura upravena (pro N zmenen typ na Long a jinak osetren pripad, ze v bunce poctu opakovani neni cislo) a osetren pripad, kdy N=0 nebo bunka poctu opakovani je prazdna, text neni kopirovan. Dale upraveno tak, ze prvni bunka bloku text nemusi byt na shodnem radku s prvni bunkou bloku poctu opakovani (prvni bunka ciloveho bloku mohla byt na jinem radku uz v predchozi verzi):

Kód: Vybrat vše

Option Explicit

Sub KopirovatNkrat()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OffsR As Long
  Dim OffsRws As Long, OffsClmns As Integer
  Dim N As Long, WshtRCnt As Long
  ' definovat promenne,
  ' upravit nazev listu a adresy bunek pro definici SBlk, TCll a ofsety text x pocty opakovani
  With Worksheets("January")
    ' zdrojovy blok - texty
    Set SBlk = .Range("b7:b" & .Cells(.Rows.Count, "b").End(xlUp).Row)
    ' vychozi cilova bunka
    Set TCll = .Range("j4")
    ' pocet pouzitelnych radku listu (celkem radku - radek vychozi cilove bunky)
    WshtRCnt = .Rows.Count - TCll.Row
    ' ofset prvni bunky bloku poctu opakovani oproti prvni bunce bloku text
    OffsRws = .Range("g5").Row - .Range("b7").Row
    OffsClmns = .Range("g5").Column - .Range("b7").Column
  End With
  ' vykonna smycka
  OffsR = 0  ' vychozi offset ciloveho bloku.
  For Each SCll In SBlk.Cells
    With SCll
      ' osetreni chyby, kdyz v bunce poctu opakovani neni cislo
      On Error Resume Next
      N = .Offset(OffsRws, OffsClmns).Value  ' pocet opakovani
      If Err.Number <> 0 Then
        GoTo Continue
      End If
      On Error GoTo 0
      If N > 0 Then  ' pocet opakovani > 0?
        If OffsR + N <= WshtRCnt Then  ' prekrocen pocet radku listu?
          ' definovat cilovy blok (metoda Resize() a vlastnost Offset() )
          ' podle poctu opakovani N a vyplnit podle SBlk(xx)
          TCll.Resize(N, 1).Offset(OffsR, 0).Value = .Value
          ' novy offset pro dalsi cilovy blok
          OffsR = OffsR + N
Continue:
        Else
          MsgBox "Prekrocen pocet radku listu", vbOKOnly + vbExclamation
          Exit For
        End If
      End If
    End With
  Next SCll
  ' odstranit objektove promenne
  Set SCll = Nothing
  Set SBlk = Nothing
  Set TCll = Nothing
End Sub

viz adresy bunek v prilozene procedure, uprav dle potreby. Taktez muzes vypustit casti kodu, kde si myslis, ze nemuze nastat chyba.