< návrat zpět

MS Excel


Téma: Uložení listu jako workbook rss

Zaslal/a 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

Jméno
Kontrola
Text
  b i u s img code url hr   1 2 3 4 5 6 7 8 9 10

#049444
avatar
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
citovat
#049445
avatar

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 4citovat
#049446
elninoslov
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 Sub
Příloha: zip49446_uloz-list-faktura.zip (22kB, staženo 1x)
citovat
#049449
avatar

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 1citovat
#049450
elninoslov
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.citovat
#049452
avatar

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 9citovat
#049453
avatar

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


Dim Btn As Buttoncitovat
#049457
avatar

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é?citovat
#049458
avatar

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"
citovat
#049463
avatar

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

Uživatelské menu

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

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

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

Aktivní diskuse

Tabulka dovolených 2021

lugr • 15.1. 22:00

Makro na skrytí sloupců v závislosti na název

kalisci • 15.1. 15:33

Rozkopírování dat do listů

Raders486 • 15.1. 15:30

Makro na skrytí sloupců v závislosti na název

elninoslov • 15.1. 14:16

Makro na skrytí sloupců v závislosti na název

kalisci • 15.1. 10:50

Tabulka dovolených 2021

lugr • 14.1. 18:29

Změna hypertextového odkazu po proceduře

Raders486 • 14.1. 16:40