< návrat zpět
MS Excel
Téma: VBA ulozit ako xlsx a vymazat dáta v xlsm 
Zaslal/a kabaka 9.11.2025 9:19
Dobrý deň
Potrebujem pomoc, prosím, ďakujem.
Mám 2 súbory. zdroj.xls, exportovaný zo serveru a uložený ako xls, dáta ručne kopírujem do súboru makro promis.xlsm (office 2007)
Makro funguje.
Ale ešte chcem, aby po uložení súboru xlsx, sa vymazali dáta v pôvodnom xlsm súbore. A to sa mi nedarí.
Sub OPpromisakt()
' vymazat stlpce
Columns("A:I").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft
Columns("O:U").Select
Selection.Delete Shift:=xlToLeft
Columns("R:V").Select
Selection.Delete Shift:=xlToLeft
' usporiadat stlpce
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("P:P").Select
Selection.Cut
Range("B1").Select
ActiveSheet.Paste
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("R:R").Select
Selection.Cut
Range("C1").Select
ActiveSheet.Paste
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("T:T").Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Columns("V:V").Select
Selection.Cut
Range("G1").Select
ActiveSheet.Paste
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Columns("P:P").Select
Selection.Cut
Range("I1").Select
ActiveSheet.Paste
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Columns("U:U").Select
Selection.Cut
Range("J1").Select
ActiveSheet.Paste
Columns("V:V").Select
Selection.Cut
Range("K1").Select
ActiveSheet.Paste
Columns("AC:AC").Select
Selection.Cut
Range("L1").Select
ActiveSheet.Paste
Columns("AB:AB").Select
Selection.Cut
Range("M1").Select
ActiveSheet.Paste
Columns("Q:Q").Select
Selection.Insert Shift:=xlToRight
Columns("S:S").Select
Selection.Cut
Range("Q1").Select
ActiveSheet.Paste
Columns("S:S").Select
Selection.Delete Shift:=xlToLeft
Columns("T:V").Select
Range("V1").Activate
Selection.Delete Shift:=xlToLeft
'odstraniť nepotrebné riadky
Dim ws As Worksheet
Dim i As Long
Set ws = ThisWorkbook.Sheets("makro")
' Loop from the last row in column F (Department) to the first row
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "CZS_01" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "CZS_02" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "CZS_03" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "CZS_04" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "CZS_05" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "ENDO" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "Bronchoskopia" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "Kolonoskopia" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "LITO / RTG" Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "RTG-CT " Then
ws.Rows(i).Delete
End If
Next i
For i = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If ws.Cells(i, "A").Value = "RTG-ERCP" Then
ws.Rows(i).Delete
End If
Next i
'ulozit
Dim Cesta As String, Subor As String, Mesiac As String, Datum As Date
Const ZDROJ_DATUMU = "makro"
Typ = IIf(Val(Application.Version) < 11, xlOpenXMLWorkbook, 51)
Cesta = ThisWorkbook.Path & "\"
Datum = Worksheets(ZDROJ_DATUMU).Cells(1, 2)
Mesiac = Format(Datum, "dd.mm.yyyy")
Subor = Cesta & "Akt OP " & Mesiac & ".xlsx"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs filename:=Subor, FileFormat:=Typ, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
Začátečník(10.11.2025 13:13)#057585 
Problém je, že ActiveWorkbook.SaveAs uloží stávající XLSM soubor jako XLSX a původní XLSM soubor zůstává beze změny, pokud nebyl ručně uložen před spuštěním makra. Tedy obdoba klasického "Uložit soubor jako".
Nějak jsem nepochopil, co je cílem celého snažení.
Jde o překopírování a přesunutí sloupců ze souboru zdroj.xlsx do jiného definovaného souboru (jméno v proměnné Subor)
K čemu slouží soubor
promis.xlsm? Jen ke spuštění makra, nebo to má hlubší význam, kolik obsahuje listů, kolik listů má být uloženo do vytvořeného souboru?
Zdrojový soubor
zdroj.xls má vždy tento název? ...
Pokud by byly nějaké ukázky zdrojových a cílových dat jak to má vypadat, asi by se dalo něco napsat. Takhle zbytečně dlouhý kód zde moc na přehlednosti příspěvků a odpovědí nepřidá.
Stačí pár řádků ukázkových dat
bez citlivých údajů.
EDIT:
pokud jde o pouhé uložení
'ulozit
Dim WS As Worksheet
Dim Cesta As String, Subor As String, Mesiac As String, Datum As Date
Set WS = Worksheets("makro")
Cesta = ThisWorkbook.Path & "\"
Datum = WS.Cells(1, 2)
Mesiac = Format(Datum, "dd.mm.yyyy")
Subor = Cesta & "Akt OP " & Mesiac & ".xlsx"
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
' Zkopírovat list do nového sešitu
WS.Copy
ActiveWorkbook.SaveAs Filename:=Subor, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
' Vymazat data z původního listu
WS.Cells.ClearContents
Set WS = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
ovšem i ostatní kód volá po optimalizaci, zbytečné použití Select a následné Selection, zbytečné opakované cykly pro výmaz řádek splňující podmínky sloučit do jednoho průchodu (v případě velkého objemu dat to způsobí dost velké prodlení) ...
Za sebe bych řešil otevřením zdrojového souboru, překopírováním pouze zájmových sloupců ve správném pořadí (např. podle identifikace v prvním řádku - nadpisy sloupců) a následně uložení takto vytvořeného listu a zavření zdrojového souboru.
citovat€Ł мσşqμΐτσ(13.11.2025 17:47)#057592 
Přikládám soubor, ve kterém jsem upravil a zjednodušil původní makro.
K tomu jsem přidal ještě dvě nová makra, která řeší import dat efektivněji:
1. Zkrácená a optimalizovaná verze původního makra – stejná funkce, ale výrazně jednodušší a rychlejší kód.
2. Makro s klasickým načtením (Workbooks.Open) – vezme ze zdrojového souboru pouze požadované sloupce, vloží je do listu Data, odstraní nepotřebné řádky a uloží výsledek jako .xlsx.
3. Makro s ADO (bez otevírání souboru) – ještě rychlejší varianta, která načítá data přímo z disku bez otevření Excelu; opět bere jen potřebné sloupce, uloží do listu Data, smaže nepotřebné řádky a vytvoří finální .xlsx.
Vše je nastaveno tak, aby se po zpracování mezidata z listu Data automaticky vyčistila. Ale jelikož nevím na kterém listu má být datum, (B1) tak jsem to přidal na list "makro"
Samozřejmě je vše potřeba ověřit.Příloha: 
57592_test.zip (38kB, staženo 8x) citovatkabaka(15.11.2025 17:25)#057598 Prikladám súbor.
Začátečník napsal/a:
EDIT:pokud jde o pouhé uložení
Super, toto je ono. To je presne to, čo som potrebovala.
Uložiť a vytvoriť xlsx a vymazať dáta makre. Toto mi stačí.
Ďakujem.
Ale ešte potrebujem pridať vyfarbenie konštany neop. dodatok, služba a príslužba. /neop. červená, dodatok, zelená a služba a príslužba modrá/
Áno súbor makro promis.xlsm má slúžiť na spustenie makra.
EDIT
' otvorit zdrojovy subor s datami
Workbooks.Open Filename:="C:\Users\P1511CEA\Desktop\zdroj.xls"
Zdrojový súbor sa bude volať vždy rovnako zdroj.
Pridala som do makra ešte kód. Súbor makro promis.xlsm rovno otvorí súbor zdroj.xlsx
Hárok v zdroji sa musí volať makro a hárok v zdroji sa musí volať promis, aby to fungovalo tak ako má.
V súbori zdroj pridávam 2 riadky. Do bunky J napíšem Aktualizovaný OP, a do bunky AG1 dátum.
Vymenená príloha. Je to to isté, len s jedným pridaným kódom.
Příloha: 57598_wall.zip (42kB, staženo 9x) citovatZačátečník(16.11.2025 19:46)#057604 Upravený kód (podle návrhu €Ł мσşqμΐτσ).
Snad jsem správně pochopil zadání pro obarvení, neuvádíte co se má obarvit, tak se obarví celý řádek s daty.
Podmínkou je existence souboru ve stejné složce jako je zdrojový soubor makra.
Testy a ošetření chyb (existence souboru atd.) není součástí.
Příloha: 57604_wall.zip (45kB, staženo 6x) citovatkabaka(16.11.2025 22:29)#057605 Začátečník napsal/a:
Upravený kód (podle návrhu €Ł мσşqμΐτσ).
Geniálne funguje to perfektne. Ďakujem veľmi pekne.
Má to len 1 malú chybičku. Nezoraďuje riadky podľa posledného stĺpca T.
citovatStačí přidat řádek
.Range("A3:T" & posledni).Sort Key1:=.Range("T3"), Order1:=xlAscending, Header:=xlYes viz obrázek(ukazka.jpg)kam
Příloha: 
57606_ukazka.jpg (47kB, staženo 8x)
citovatkabaka(17.11.2025 9:20)#057607 €Ł мσşqμΐτσ napsal/a:
Stačí přidat řádek
.Range("A3:T" & posledni).Sort Key1:=.Range("T3"), Order1:=xlAscending, Header:=xlYes
Ďakujem pekne. Ale ignoruje stĺpec A.
Ide o zoradenie podľa 2 podmienok. Stĺpec A a T.
citovatZačátečník(17.11.2025 9:32)#057608 Řazení jsem přehlédl, upravený kód včetně řazení podle sloupce T a A
Příloha: 57608_wall.zip (46kB, staženo 4x) citovatkabaka(17.11.2025 9:38)#057609 Začátečník napsal/a:
Řazení jsem přehlédl, upravený kód včetně řazení podle sloupce T a A)
Ďakuje veľmi pekne. Teraz to funguje ako má.
citovatZačátečník(17.11.2025 10:17)#057610 Není zač, nevím nakolik je příjemné spouštět kód přes menu maker výběrem, pohodlnější by bylo buď spouštět automaticky při otevření sešitu (případně dotazem na spuštění), nebo přes tlačítko na listu.
Tlačítko by se pak před uložením kopie muselo z listu vymazat.
V příloze varianty.
Příloha: 57610_wall.zip (104kB, staženo 13x) citovat
\n
RSS nejnovější články