< návrat zpět

MS Excel

Téma: MAKRO_pro_celou_slozku rss

Zaslal/a Jakub_Kovarik 4.10.2012 10:47

Dobrý den,
mám makro, které jsem nahrál. Omlouvám se za zbytečné řádky, ale jsem úplný začátečník.
Potřeboval bych, aby se toto makro spustilo na vsechny soubory ve slozce, takto musim vsechny soubory jednotlive otevirat a ukladat, coz zabira strasne casu, Budu vdecny za kazdou radu. Preji hezky den.

Rows("1:6").Select
Selection.Delete Shift:=xlUp
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 17
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 19
ActiveWindow.ScrollRow = 20
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 23
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 25
ActiveWindow.ScrollRow = 26
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 28
ActiveWindow.ScrollRow = 29
ActiveWindow.ScrollRow = 30
ActiveWindow.ScrollRow = 31
ActiveWindow.ScrollRow = 32
ActiveWindow.ScrollRow = 33
ActiveWindow.ScrollRow = 34
ActiveWindow.ScrollRow = 36
ActiveWindow.ScrollRow = 37
ActiveWindow.ScrollRow = 38
Rows("53:367").Select
Selection.Delete Shift:=xlUp
Range("G46").Select
ActiveWindow.ScrollRow = 35
ActiveWindow.ScrollRow = 31
ActiveWindow.ScrollRow = 25
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 1
Columns("A:A").ColumnWidth = 50
ActiveCell.Replace What:=",", Replacement:=";", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:=",", Replacement:=";", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveWindow.ScrollRow = 30
ActiveWindow.ScrollRow = 28
ActiveWindow.ScrollRow = 26
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 20
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 1
Range("A1:A52").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), TrailingMinusNumbers:=True
Range("L18").Select
Columns("A:A").ColumnWidth = 15.43

Zaslat odpověď >
Milan-D(4.10.2012 13:59)#009725
avatar
Tak se podivej na tento prispevek zpred dvou dnu: http://wall.cz/index.php?m=topic&id=9675

Je tam kod, ten te vybidne k otevreni zvoleneho adresare, kde oznacis soubory, ktere potrebujes. Vykonne radky jsou pouze tyto tri, vse ostatni v kodu zrejme zustane stejne.

'nakopiruj listy do wb
For j = 1 To wbX.Sheets.Count
wbX.Sheets(j).Copy after:=wb.Sheets(wb.Sheets.Count)
Next j

Takze tyto 3 radky vyhod a misto nich vloz to svoje nahrane makro a uvidis vysledek. Btw. pises soubory, ale uz se nezminujes o listech, takze asi se ti jedna jen o prvni list. Ma nejaky konstantni nazev?
Jinak vsechny radky kde scrollujes klidne vymaz. Ty nemaji prakticky zadny vliv na funkci.
Jo a dulezite: nejdriv si ty soubory zazalohuj. Doporucuji si hodit VBA okno na pulku obrazovky a excel na druhou pulku. Pak klikej na F8 ve VBA okne a budes videt prislusnou odezvu v excelu. Nejlepsi zpusob, jak se rychle obeznamit s "makry"citovat
Jakub_kovarik2(5.10.2012 10:45)#009732
avatar
Dobrý den,
velice dekuji za reakci. Já potrebuji, aby makro viz vyse udelalo stejnou zmenu ve vsecvh souborech, co jsou ve slozce, nechci je spojovat. Ano, tabulka je na prvnim liste a kazdy soubor se jmenuje jinak a pote by se soubor ulozil. Moc dekuji za Vasi odpoved.citovat
Milan-D(5.10.2012 14:06)#009733
avatar
Ale vzdyt mou odpoved mas: pouzij ten kod. Ty tri radky, ktere delali neco jineho nez potrebujes (kopirovani listu do jednoho souboru) jednoduse vymaz, a misto nich tam dej procistene svoje makro. Vysledkem bude procedura, ktera postupne otevre vsechny soubory, ktere oznacis a vykona na nich prikazy Tveho makra.

Pokud se vse ma odehravat na prvnim listu kazdeho oznaceneho soboru, mohl bys tam pro sichr vlozit, pote co se dany soubor otevre, prikaz pro aktivaci prvniho listu: Worksheets(1).Activate Co by jeste mohlo zlobit je tento radek kodu:
.Filters.Add "Excel", "*.xls" Pokud mas ty svoje soubory v jinem excel. formatu, napr: xlsx, xlsm, csv... tak bud si s tim filtrem pohraj anebo ho klidne vynech, pak uvidis vsechny typy souboru v danem adresari.
Kod pro ulozeni souboru je
wbX.Save anebo rovnou i se zavrenim
wbX.Close(1)Tedy udelej jak rikam, jestli se vyskytne problem klidne pomuzu, pokud uvidim, ze ses vynalozil usilicitovat
Jakub_Kovarik(6.10.2012 11:44)#009744
avatar
Dobrý den,
velice děkuji, dal jsem to dohramdy. Musel jsem se na to více podívat - funguje to :-) . Chtěl bych se jeste zeptat, co se tyce ukladani, mam ty soubory csv. Kdyz je ulozim opet v csv, tak se rozhazi formatovani,co makro vytvorilo, jak ulozim v makru soubor s priponou xls, nebo xlm? se stejnym nazvem, co soubor mel jako csv?citovat
marjankaj(6.10.2012 11:53)#009745
avatar
Jakub
Prosím ťa, vymaž si aspoň tie
ActiveWindow.ScrollRow
v úvodnom príspevku.
Nedá sa na to pozerať.
Ď.

Ak si dáš zaznamenať makro a potom dáš uložiť súbor. Tak po ukončení záznamu makra by si tam mal mať niečo takéto.

ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\jan\Dokumenty\Zošit1.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=Falsecitovat
Jakub_Kovarik(6.10.2012 12:16)#009746
avatar
Dekuji, vymazu :-) a kdyz tam zadam nazev souboru, tak pro kazdy soubor je nazev jiny, jak tam dam neco jako promennou, co automaticky vezme nazev souboru, at to tam pro kazdy soubor nemusim psat rucne?citovat
marjankaj(6.10.2012 12:59)#009747
avatar
cesta="C:\Documents and Settings\jan\Dokumenty\"

for i=1 to 10

jmeno=cesta & "sešit" & i & ".xls" 'Alebo jmeno=cesta & cells(i,1)
ActiveWorkbook.SaveAs Filename:= jmeno
next icitovat
Jakub_Kovarik(6.10.2012 14:12)#009748
avatar
Super, dekuji moc - princip funguje dobre. Akorat mam problem, nahrazuji , za ; a . za , a tato zmena se provede vzdy jen u posledniho souboru spravne, ve zbytku zustava tecka a bunka se bere jako textovy retezec.

Sub Makro1()
'
' Makro1 Makro
'

Dim wb As Workbook, wbX As Workbook
Dim i As Integer, j As Integer

'zkratka pro tento sesit
Set wb = ThisWorkbook

' Otevri dialog
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = ""
.AllowMultiSelect = True
.Filters.Add "Excel", "*.xls"
.Show

' pro kazdy soubor
For i = 1 To .SelectedItems.Count

Workbooks.Open .SelectedItems(i)
Set wbX = ActiveWorkbook
'nakopiruj listy do wb
Rows("1:112").Select
Selection.Delete Shift:=xlUp
Range("I17").Select

Rows("54:266").Select
Selection.Delete Shift:=xlUp

Range("J10").Select
Columns("A:A").ColumnWidth = 48.14
Range("A1:A52").Select
Selection.Replace What:=",", Replacement:=";", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), TrailingMinusNumbers:=True
Columns("A:A").ColumnWidth = 14.57
Range("L11").Select
Next i

cesta = "C:\Users\Jakub\Desktop\SPY_hotove_data"
For p = 1 To 2
jmeno = cesta & "sešit" & p & ".xls" 'Alebo jmeno=cells(i,1)
ActiveWorkbook.SaveAs Filename:=jmeno

Next p
End Withcitovat
Jakub_Kovarik(6.10.2012 14:23)#009749
avatar
už to mám. jste borci, jednou bych chtěl umět to co vy :-)citovat
Jakub_Kovarik(6.10.2012 14:33)#009750
avatar
Tak nemám, první způsob toho ukládání funguje dobře, ale ve všech, kromě posledního se mi neudělá správně to zaznamenané makro.citovat

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