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 Sub
citovat