< návrat zpět
MS Excel
Téma: Uložení listu jako workbook 
Zaslal/a John89 12.1.2021 13:39
Ahoj, snažím se uložit list excelu jako samostatny workbook bez funkcí, na tom listu, který potřebuji uložit mám 2x button (Form Control), které nechci aby se mi uložili do nového sešitu. Jde to nějak jednoduše udělat?
Sub Save sheet as workbook()
CestaAdresare2 = Sheets("Nastaveni").Range("F3").Text
a = Sheets("Nastaveni").Range("F1").Text 'skladani textu pro nazev souboru
b = Sheets("Nastaveni").Range("H1").Text 'skladani textu pro nazev souboru
abcd = a & b ' sloučení textu pro nazev souboru
souborxls = CestaAdresare2 & "\" & abcd & ".xlsx"
Sheets("Faktura").Select
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Copy
.PasteSpecial xlValues
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveCopyAs Filename:=souborxls
'ActiveWorkbook.Close (False)
End Sub
Milan-158(12.1.2021 14:33)#049444 
Ve svém kódu řeším něco podobného, čili ukládám list jako samostatný soubor. Zde je část, která vymaže všechny Shapes (což jsou třeba tlačítka, obrázky atd,) kromě některých. Rozlišuje se to podle typu Shape.Type
'velikost loga a textboxu se rozhodila, tak ji nastavíme znovu
For i = ActiveSheet.Shapes.Count To 1 Step -1
With ActiveSheet.Shapes(i)
If .Type = 13 Then 'type 13 je logo
.LockAspectRatio = msoFalse
.Height = 20
.Width = 184
ElseIf .Type = 17 Then 'type 17 je textbox
.LockAspectRatio = msoFalse
.Height = 22
.Width = 145
Else 'jinak smazat
.Delete
End If
End With
Next i
citovatjohn89(12.1.2021 15:57)#049445 Milan-158 napsal/a:
Ve svém kódu řeším něco podobného, čili ukládám list jako samostatný soubor. Zde je část, která vymaže všechny Shapes (což jsou třeba tlačítka, obrázky atd,) kromě některých. Rozlišuje se to podle typu Shape.Type
'velikost loga a textboxu se rozhodila, tak ji nastavíme znovu
For i = ActiveSheet.Shapes.Count To 1 Step -1
With ActiveSheet.Shapes(i)
If .Type = 13 Then 'type 13 je logo
.LockAspectRatio = msoFalse
.Height = 20
.Width = 184
ElseIf .Type = 17 Then 'type 17 je textbox
.LockAspectRatio = msoFalse
.Height = 22
.Width = 145
Else 'jinak smazat
.Delete
End If
End With
Next i
Děkuji jen nemůžu najít jaké číslo bude mít button form control
citovatelninoslov(12.1.2021 16:08)#049446 
Pozrite sa počas zastaveného kódu do kolekcie Shapes na jednotlivé Item a v ich vlastnostiach podľa položky ALternativeText (nápis na tlačítku) pozrite položku Name.
Worksheets("Faktura").Shapes
Sub Save_Sheet_As_Workbook()
Dim NazovSuboru As String, E As Long
With Worksheets("Nastaveni")
NazovSuboru = .Range("F3") & "\" & .Range("F1") & .Range("H1") & ".xlsx"
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo CHYBA
Worksheets("Faktura").Copy
With ActiveWorkbook
With .ActiveSheet
.Shapes("Button 1").Delete
.Shapes("Button 2").Delete
.UsedRange.Value = .UsedRange.Value
End With
.SaveAs NazovSuboru, xlOpenXMLWorkbook
.Close False
End With
E = vbInformation
GoTo POKRACUJ
CHYBA:
E = vbCritical
POKRACUJ:
MsgBox IIf(E = vbCritical, "Nastala chyba", "Uloženo"), E
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End SubPříloha: 
49446_uloz-list-faktura.zip (22kB, staženo 13x) citovatjohn89(12.1.2021 17:45)#049449 elninoslov napsal/a:
Pozrite sa počas zastaveného kódu do kolekcie Shapes na jednotlivé Item a v ich vlastnostiach podľa položky ALternativeText (nápis na tlačítku) pozrite položku Name.
Worksheets("Faktura").Shapes
Sub Save_Sheet_As_Workbook()
Dim NazovSuboru As String, E As Long
With Worksheets("Nastaveni")
NazovSuboru = .Range("F3") & "\" & .Range("F1") & .Range("H1") & ".xlsx"
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo CHYBA
Worksheets("Faktura").Copy
With ActiveWorkbook
With .ActiveSheet
.Shapes("Button 1").Delete
.Shapes("Button 2").Delete
.UsedRange.Value = .UsedRange.Value
End With
.SaveAs NazovSuboru, xlOpenXMLWorkbook
.Close False
End With
E = vbInformation
GoTo POKRACUJ
CHYBA:
E = vbCritical
POKRACUJ:
MsgBox IIf(E = vbCritical, "Nastala chyba", "Uloženo"), E
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End SubPříloha: 49446_uloz-list-faktura.zip (22kB, staženo 1x)
Děkuji takto to funguje. Jen jeste dotaz jestli lze ošetrit aby se mi novy workbook neotviral s hlaškou
https://ibb.co/J76h30q?
Děkuji
citovatelninoslov(12.1.2021 18:02)#049450 Fúha, no neviem, či to nebude verziou Excelu. Ja mám E2019 a fičí to. Skúste nemať tie makrá na tie 2 čudlíky v liste Faktura, ale v module. Aj keď u mňa je to jedno.
citovatjohn89(12.1.2021 21:10)#049452 elninoslov napsal/a:
Fúha, no neviem, či to nebude verziou Excelu. Ja mám E2019 a fičí to. Skúste nemať tie makrá na tie 2 čudlíky v liste Faktura, ale v module. Aj keď u mňa je to jedno.
Děkuji za rady. Nakonec jsem na to nepřišel proč to hází.makra mám v modulech a verzi office mam 365
Ale vyřešil jsem to takto:
Sheets("Faktura").Select
For Each Btn In ActiveSheet.Buttons
Btn.Visible = False
Next Btn
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Copy
.PasteSpecial xlValues
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveCopyAs Filename:=souborxls
ActiveWorkbook.Close (False)
pak jsem tam dal
For Each Btn In ActiveSheet.Buttons
Btn.Visible = True
Next Btn
Je to teda bastl, ale funguje to
citovatjohn89(12.1.2021 21:11)#049453 john89 napsal/a:
elninoslov napsal/a:Fúha, no neviem, či to nebude verziou Excelu. Ja mám E2019 a fičí to. Skúste nemať tie makrá na tie 2 čudlíky v liste Faktura, ale v module. Aj keď u mňa je to jedno.
Děkuji za rady. Nakonec jsem na to nepřišel proč to hází.makra mám v modulech a verzi office mam 365
Ale vyřešil jsem to takto:
Sheets("Faktura").Select
For Each Btn In ActiveSheet.Buttons
Btn.Visible = False
Next Btn
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Copy
.PasteSpecial xlValues
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveCopyAs Filename:=souborxls
ActiveWorkbook.Close (False)
pak jsem tam dal
For Each Btn In ActiveSheet.Buttons
Btn.Visible = True
Next Btn
Je to teda bastl, ale funguje to
john89(13.1.2021 16:02)#049457 elninoslov napsal/a:
Fúha, no neviem, či to nebude verziou Excelu. Ja mám E2019 a fičí to. Skúste nemať tie makrá na tie 2 čudlíky v liste Faktura, ale v module. Aj keď u mňa je to jedno.
Dobrý den, rád bych Vás požádal o radu, když zamknu list a rozeviraci seznam mam také zamknutý a pustím makro pro uložení listu jako sešit tak mi to píše: The cell or chart you're trying to change is on a protected sheet. To make a change, unprotect sheet. you might be requested to enter and password. je možné ve VBA to nějak nastavit aby to kopirovalo i když je to zamknuté?
citovatjohn89(13.1.2021 16:35)#049458 john89 napsal/a:
elninoslov napsal/a:Fúha, no neviem, či to nebude verziou Excelu. Ja mám E2019 a fičí to. Skúste nemať tie makrá na tie 2 čudlíky v liste Faktura, ale v module. Aj keď u mňa je to jedno.
Dobrý den, rád bych Vás požádal o radu, když zamknu list a rozeviraci seznam mam také zamknutý a pustím makro pro uložení listu jako sešit tak mi to píše: The cell or chart you're trying to change is on a protected sheet. To make a change, unprotect sheet. you might be requested to enter and password. je možné ve VBA to nějak nastavit aby to kopirovalo i když je to zamknuté?
Už jsem to vyřešil:
ActiveSheet.Protect "password"
ActiveSheet.UnProtect "password"
citovatlubo(13.1.2021 21:29)#049463 john89 napsal/a:
john89 napsal/
Už jsem to vyřešil:
ActiveSheet.Protect "password"
ActiveSheet.UnProtect "password"
Nebo se dá použít
ActiveSheet.Protect Password:="heslo", UserInterfaceOnly:=True
před spuštěním aktualizace.
citovat
RSS nejnovější články