MS Excel

Diky za radu. V planu mam kopie cca20listu. Je ta druha moznost narocna na napsani kodu?citovat

neviem co presne ma tvoj kod robit ale skusil by som nieco take

Sub kopiruj()

listy = Array("prvy", "druhy", "faktura", "zaloha")

For llist = 0 To UBound(listy)
Worksheets(listy(List)).Copy
ActiveSheet.Cells.UnMerge
Workbooks(zdroj).Sheets(listy(llist)).Cells.Copy
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Shapes("TL1").Delete
Next llist
End Subcitovat

Našel jsem jedno použitelné makro pro export více listů, ale pro mou potřebu bych potřeboval pomoci s úpravou(viz příloha):
Aby se kopie listů uložila bez maker, dále místo vzorců zůstala jen hodnota v buňce. Prostě aby neexistovalo žádné propojení do zdrojového sešitu. Je to reálné?

Šla by do kódu přidat možnost, aby když se zkopírují listy tak aby se zobrazila možnost uložit jako, nebo aby se nový sešit automaticky uložil pod jménem Faktura + číslo v buňce A1?
Zkoušel jsem nějaké své pokusy, ale marně:-(
Díky moc za pomoc.citovat

SUper, funguje perfektně.
Ještě se jen zeptám, bylo by těžké pojmenovat sešit dle Buňky A1 z listu Faktura?
Jinak děkuji moc. Pomohl jsi mě.citovat

Diky, funguje.
Snažil jsem se dát dohromady níže uvedený kód, ale je tam nějaká chyba. Můžete se mě na to prosím někdo juknout kde je chyba/chyby?
Kód by měl Vytvořit kopie stránek do samostatného sešitu, a ten pojmenovat dle Buňky a zobrazit možnost uložit jako. Před uložením ještě podmínka zkontroluje zda již sešit s tímto číslem existuje.
Už jsem bezradný. Prosím o pomoc.

Sub Export_listu()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

zdroj = ActiveWorkbook.Name
ChDir Application.ThisWorkbook.Path

novy_subor = Worksheets("Nabídka").Cells(13, 18).Value '
Listy = Array("Faktura", "Nabídka")

Workbooks.Add
ActiveWorkbook.SaveAs filename:= _
novy_subor, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

For llist = 0 To UBound(Listy)
Windows(zdroj).Activate
Sheets(Listy(llist)).Select

Sheets(Listy(llist)).Copy before:=Workbooks(novy_subor).Sheets(1)
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Worksheets("List1").Delete
Worksheets("List2").Delete
Worksheets("List3").Delete
Worksheets("Nabídka").Activate
Range("A1").Select

' následuje přejmenování

nove_jmeno = "" & novy_subor ' buňka I1 - číslo faktury
' nastavení cesty pro uložení
Dim filename As Variant
filename = Application.GetSaveAsFilename(nove_jmeno, "Excel (*.xls),*.*,Excel 07 (*.xls),*.*,", 1, "Uložit jako")
If filename = False Then Exit Sub
cele_jmeno = filename

'=existuje uz soubor faktury?
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(cele_jmeno) Then
sZprava = MsgBox("Ve vámi zvoleném adresáři již tento soubor existuje, chcete tento soubor přepsat?" & vbCrLf & "...zápis v databazi bude nezměněn...", vbYesNo, "Přepsat soubor?")
Select Case sZprava
Case vbNo
Workbooks(Workbooks.Count).Close (False)
Application.CutCopyMode = False
Exit Sub
Case vbYes
End Select
End If
Next llist

Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWorkbook.Close

End Subcitovat