< návrat zpět

MS Excel

Téma: VBA ulozit ako xlsx a vymazat dáta v xlsm rss

Zaslal/a kabaka 9.11.2025 9:19

kabakaDobrý 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

Zaslat odpověď >
Začátečník(10.11.2025 13:13)#057585
Začátečník
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

Uživatelské menu

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

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