Makro - rozklad databazy do osobitnych excelov Vyřešeno

[afabiavi]

Ahojte,
velmi casto potrebujem jeden hlavny data sumarizujuci subor rozlozit na viacero mensich suborov s datami pre danu krajinu, a to tak ze data pre danu krajinu su ulozene v osobitnom exceli a meno excelu obsahuje meno krajiny.
Vytvorila som si svojpomocne makro, ktore funguje, avsak je velmi primitivne a je casovo narocne ho aplikovat na obdobne subory. Musim ho zakazdym manualne upravit ( zmena nazvu excelu, zmena poctu stlpcov hlavicky, adt. ).
Existuje nejaky sposob ako toto makro zjednodusit, a viac zautomatizovat ?
Napr. : zober hlavnu stalesaopakujucu hlavicku, k nej vzdy daj data danej krajiny, uloz to ako osobitny excel s nazvov zhodnym s datami v bunke 1 danej krajiny. A teraz to iste ale s datami krajiny o jeden stlpec napravo a atd. Az dokym budu stlpce obsahovat data.
Alebo ak aj existuje iny sposob ako to urobit. Dakujem. Dost sa s tym trapim, kedze som uplny zaciatocnik ...
Prikladam aj moje makro a subor.

[Reklama]

[cmuch]

Vítej na PC-Help

Skus toto makro

Kód: Vybrat vše

Sub Rozdelenie()

Dim ZdrojovySoubor As Variant
Dim LastCell, Kraj As Long
Dim LastKraj As Variant
Dim CestaKsouboru, NazevSouboru As String

'
Application.ScreenUpdating = False

' Nazev tohoto sesitu
ZdrojovySoubor = ActiveWorkbook.Name

' Posledni sloupec s krajinou
LastCell = Cells(6, Columns.Count).End(xlToLeft).Column

 ' Opakuj od sl.O po posledni kraj
 For Kraj = 15 To LastCell

    ' nazev krajiny
    LastKraj = Mid(Cells(6, Kraj), 1, 2)
   
    CestaKsouboru = "C:\Users\viera.kurekova\Desktop\country files\"
    NazevSouboru = "2012-12-07 data rocneho vyhodnotenia " & LastKraj & ".xlsx"
   
    Workbooks.Add
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        CestaKsouboru & NazevSouboru, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
       
    Workbooks(ZdrojovySoubor).Sheets("TM").Columns("A:I").Copy _
      Destination:=Workbooks(NazevSouboru).Sheets("List1").Range("A1")
   
    Workbooks(ZdrojovySoubor).Sheets("TM").Columns(Kraj).Copy _
      Destination:=Workbooks(NazevSouboru).Sheets("List1").Range("J1")
   
    With Workbooks(NazevSouboru)
         .Save
         .Close
    End With
 Next Kraj
 Application.ScreenUpdating = True
 
 MsgBox " Rozdeleno "
 
End Sub


[afabiavi]

Dakujem za rychle poslanie makra.
Dost dlho som si s nim nevedela rady, no dnes som na to prisla : )

Uvedomila som ze pracujem s anglickou verziou excelu a v tejto casti som len vymenila List1 za Sheet1 a funguje to perfektne.

Workbooks(ZdrojovySoubor).Sheets("TM").Columns("A:I").Copy _
Destination:=Workbooks(NazevSouboru).Sheets("List1").Range("A1")

Dakujem este raz.