< návrat zpět

MS Excel

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

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

Zaslat odpověď >
Milan-158(12.1.2021 14:33)#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
john89(12.1.2021 15:57)#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
elninoslov(12.1.2021 16:08)#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 14x)
citovat
john89(12.1.2021 17:45)#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
elninoslov(12.1.2021 18:02)#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
john89(12.1.2021 21:10)#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
john89(12.1.2021 21:11)#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
john89(13.1.2021 16:02)#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
john89(13.1.2021 16:35)#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
lubo(13.1.2021 21:29)#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

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