< návrat zpět

MS Excel

Téma: kopírování daného počtu řádků do jiného sešitu rss

Zaslal/a dudokaktus 12.10.2014 12:16

Ahoj, prosím o radu jsem z toho v pasti, nevím jestli to pude? Děkuji za jakoukoli radu pokud budete mít někdo chvilku se tím zabývat.

Mám sešit v tom sešitě mám hodnoty, které jsou někdy od A3 řádku do 10 někdy jsou hodnoty do 100 řádků i více. Chtěl bych, aby se každých 16 řádků i se sloupci A3 až G3 nakopírovalo do nového sešitu na nový list. Když jich bude 17 řádků, tak 16 se nakopíruje do druhého listu a ten 17 do třetího listu a další listy by vytvářel vzorcem v stejném sešitě. Měl by ale poznat vzorcem jestli je či není na 18 řádku nebo dalším nějaká hodnota. V prvním listě by měla být naformátovaná tabulka, a když začne Excel kopírovat hodnoty z jiného sešitu, který vždy ručně vyberu, z jakého sešitu to bude. Tak se přitom do dalších listů bude kopírovat i ta tabulka a vzor tabulky by byl na prvním listě.
Je možné vytvořit toto bez maker jen pomoci vzorců, jaké by byli vzorce nebo postup?
Kdyby bylo s makrem, jak by vypadalo?

Zaslat odpověď >
Devil(14.10.2014 15:11)#021876
avatar
myslím, že bez maker tohle neuděláš, nepřiměješ žádným vzorcem otevřít excel nový sešit a do něj vkládat hodnoty, to prostě nende..

na makra to zas tak složitě nezní, ale trochu se ztrácím v tom Tvým popisu, hodil by se example..citovat
ijk(10.1.2015 15:45)#023074
avatar
Asi takhle: poslal http://makra.webz.cz

Sub KopirovatPo16radcich()
'POPIS MAKRA
'kopiruje radky po 16 do dalsich listu od bunky A3
'(predpokladam, ze bunky ve sloupci A jsou vzdy vyplneny - neni v nem prazdna bunka)
'--------------------------------------------------
'zjistim pocet vyplnenych radku od bunky A3
pocetRadku = Sheets(1).Range("A3").End(xlDown).Row
'pokud je list prazdny
If pocetRadku > 65535 And Sheets(1).Range("A3") = "" Then
MsgBox "Není vyplněn žádný údaj ve sloupci A"
Exit Sub
End If
'pokud je vyplnena jen bunka A3
If pocetRadku > 65535 And Sheets(1).Range("A3") <> "" Then
pocetRadku = 3
End If
'pocet vyplnovanych listu
pocetVyplnovanychListu = Int((pocetRadku - 2) / 16) + 1
'kdyz je malo listu pridej dalsi
pocetListuSesitu = Sheets.Count
If pocetListuSesitu < pocetVyplnovanychListu + 1 Then
'kolik listu pridame
pocetPridavanychListu = pocetVyplnovanychListu + 1 - pocetListuSesitu
For i = 1 To pocetPridavanychListu
'v cyklu pridame listy na konec
pocetListuSesitu = Sheets.Count
'pridej list
Set pridany = Sheets.Add
'presun list na konec
Sheets(pridany.Name).Move After:=Sheets(pocetListuSesitu + 1)
Next i
End If
'mazat listy kdyby neco zustalo z predchoziho kopirovani
For i = 2 To pocetVyplnovanychListu + 1
Sheets(i).Range("A3:G18") = ""
Next i
'kopiruj radky v cyklu pomoci schranky (slo by i bez schranky kazdou bunku zvlast)
For i = 2 To pocetVyplnovanychListu + 1
'kopiruj z listu 1 vzdy 16 radku (sloupce A:F) do prislusneho listu
radek1 = 3 + (i - 2) * 16
radek2 = 2 + (i - 1) * 16
'vyber kopirovanou oblast
Sheets(1).Select
Range("A" & radek1 & ":G" & radek2).Select
'kopiruj vybrane do schranky
Selection.Copy
'vyber kam kopirovat
Sheets(i).Select
Range("A3").Select
'vloz ze schranky
ActiveSheet.Paste
Range("A3").Select
Next i
'vyber list 1
Application.CutCopyMode = False
Sheets(1).Select
Range("A3").Select
MsgBox "Kopírování dokončeno"
End Subcitovat
ijk(10.1.2015 16:17)#023075
avatar
Předchozí ukázka byla kopírování dat do stejného sešitu,
tato ukázka kopíruje do nového sešitu do stejné složky.

Sub KopirovatPo16radcichDoNovehoSesitu()
'POPIS MAKRA
'kopiruje radky po 16 do noveho souboru do listu po 16 od bunky A3
'(predpokladam, ze bunky ve sloupci A jsou vzdy vyplneny - neni v nem prazdna bunka)
'spustit makro KopirovatPo16radcichDoNovehoSesitu pri vybranem 1. listu
'-----------------------------------------------------------------------------------
'zjistim pocet vyplnenych radku od bunky A3
pocetRadku = Sheets(1).Range("A3").End(xlDown).Row
'pokud je list prazdny
If pocetRadku > 65535 And Sheets(1).Range("A3") = "" Then
MsgBox "Není vyplněn žádný údaj ve sloupci A"
Exit Sub
End If
'pokud je vyplnena jen bunka A3
If pocetRadku > 65535 And Sheets(1).Range("A3") <> "" Then
pocetRadku = 3
End If
'pocet vyplnovanych listu
pocetVyplnovanychListu = Int((pocetRadku - 2) / 16) + 1
'cesta naseho souboru s daty
cesta0 = ActiveWorkbook.Path
'jmeno naseho souboru s daty
jmeno0 = ActiveWorkbook.Name
'vytvorit novy sesit
Set sesit = Workbooks.Add
'jmeno noveho sesitu
jmeno = ActiveWorkbook.Name

'kdyz je malo listu v novem sesite pridej dalsi
pocetListuSesitu = Workbooks(jmeno).Sheets.Count
If pocetListuSesitu < pocetVyplnovanychListu Then
'kolik listu pridame
pocetPridavanychListu = pocetVyplnovanychListu - pocetListuSesitu
For i = 1 To pocetPridavanychListu
'v cyklu pridame listy na konec
pocetListuSesitu = Sheets.Count
'pridej list
Set pridany = Sheets.Add
'presun list na konec
Sheets(pridany.Name).Move After:=Sheets(pocetListuSesitu + 1)
Next i
End If
'kopiruj radky v cyklu pomoci schranky (slo by i bez schranky kazdou bunku zvlast)
For i = 1 To pocetVyplnovanychListu
'kopiruj z listu 1 vzdy 16 radku (sloupce A:F) do prislusneho listu noveho sesitu
radek1 = 3 + (i - 1) * 16
radek2 = 2 + (i) * 16
'vyber kopirovanou oblast
Workbooks(jmeno0).Activate
Sheets(1).Select
Range("A" & radek1 & ":G" & radek2).Select
'kopiruj vybrane do schranky
Selection.Copy
'vyber kam kopirovat
Workbooks(jmeno).Activate
Sheets(i).Select
Range("A3").Select
'vloz ze schranky
ActiveSheet.Paste
Range("A3").Select
Next i
'uloz novy sesit
Workbooks(jmeno).Activate
Sheets(1).Select
ActiveWorkbook.SaveAs cesta0 & "\" & jmeno & ".xls"
ActiveWorkbook.Close
'vyber list 1
Application.CutCopyMode = False
Sheets(1).Select
Range("A3").Select
MsgBox "Kopírování do sešitu " & jmeno & ".xls dokončeno"
End Subcitovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje