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

Zaslat odpověď >

Strana: « předchozí 1 2

kabaka(17.11.2025 14:03)#057611

Začátečník napsal/a:

V příloze varianty

Ďakujem veľmi pekne za varianty. Tá prvá je super.citovat

Strana: « předchozí 1 2

Uživatelské menu

Nejste přihlášen(a)

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio