< návrat zpět

MS Excel

Téma: Kopie otevřeného sešitu rss

Zaslal/a marficek119 19.2.2012 9:17

Zdravím, potřebuji poradit. Mám otevřený sešit a potřebuji makrem zkopírovat, vytvořit kopii, celého sešitu i s makry, ale tak aby se mě zdrojový sešit (ze kterého provedu kopii) nezavřel. Už nevím jak postupovat, zkoušel to i se záznamem makra, ale když se mě povede udělat kopii sešitu, tak se původní sešit zavře a otevře se kopie sešitu. Přikládám kód. Děkuji za případnou pomoc.
Private Sub CommandButton1_Click()

Dim cesta As String
Dim nove_jmeno As String
Dim cele_jmeno As String
Dim zdroj As String
Dim c_Faktury As String
zdroj = ActiveWorkbook.Name
Dim doDB As Boolean

' EXPORT NABÍDKY
Application.ScreenUpdating = True
doDB = True

' nastavení cesty pro uložení dat - tam kde byl původní sešit otevřen
cesta = ActiveWorkbook.Path
Application.DisplayAlerts = False

c_Faktury = Worksheets("Nabídka").Cells(3, 1).Value ' Číslo faktury

'existuje už v databazi?
For i = 6 To Worksheets("Databáze faktur").Cells(65000, 2).End(xlUp).Row + 1
If c_Faktury = Worksheets("Databáze faktur").Cells(i, 2) Then
f_zprava = MsgBox("V databázi už tato nabídka existuje, chcete přesto provést export?", vbYesNo, "Nabídka už existuje")
Select Case f_zprava
Case vbNo
Exit Sub
Case vbYes
doDB = False
End Select
End If
Next i

' po stisku tlačítka Ulož Nabídku
' zkopíruje celý sešit
ActiveWorkbook.SaveAs


' aktivním sešitem je nově zkopírovaný
' následuje přejmenování

nove_jmeno = c_Faktury & " nabídka" ' 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?
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

' uložení sešitu do standadní cesty ukládání
ActiveWorkbook.SaveAs (cele_jmeno)

' zavření nově vytvořeného sešitu
ActiveWorkbook.Close

'ulozeni faktury-odkazu, jmena a splatnosti do databaze
Workbooks(zdroj).Activate

Radek = Worksheets("Databáze faktur").Cells(65000, 2).End(xlUp).Row + 1
If doDB = True Then
Worksheets("Databáze faktur").Cells(Radek, 3) = Worksheets("Nabídka").Range("I10") 'Jméno
Worksheets("Databáze faktur").Cells(Radek, 4) = Worksheets("Nabídka").Range("K16") 'Datum vystavení
Worksheets("Databáze faktur").Cells(Radek, 2).Formula = "=hyperlink(""" & cele_jmeno & """,""" & c_Faktury & """)"
End If

Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.ScreenUpdating = False

End Sub

Zaslat odpověď >
Richard99(19.2.2012 10:11)#007339
avatar
Awb_name=ActiveWorkbook.path & "\" & activeworkbook.name

' uložení sešitu do standadní cesty ukládání
ActiveWorkbook.SaveAs (cele_jmeno)

' zavření nově vytvořeného sešitu
ActiveWorkbook.Close

Workbooks.Open Filename:= Awb_namecitovat
marficek119(19.2.2012 10:51)#007340
avatar
Děkuji ti, ale potřebuji radu kam do kódu vložit:
Awb_name=ActiveWorkbook.path & "\" & activeworkbook.name
a
Workbooks.Open Filename:= Awb_name

Něco dělám blbě a asi jsem to špatně vložil do kódu.citovat
Richard99(19.2.2012 11:41)#007342
avatar
Omlouvám se, blbě jsem to vytáhl z rozsáhlejšího kódu, tohle jsem pro jistotu vyzkoušel a funguje to.

Sub pokus()
awb_name = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

' uložení sešitu do standadní cesty ukládání
ActiveWorkbook.SaveAs ("sesit5.xlsm")

' zavrení nove vytvoreného sešitu
awb2_name = ActiveWorkbook.Name
Workbooks.Open Filename:=awb_name
Windows(awb2_name).Close
End Subcitovat
marficek119(19.2.2012 12:05)#007345
avatar
Tak jsem z toho jelen, samotný kód funguje, ale pokud se pokusím přidat tvůj kód do mého, tak mě to vyhazuje error. Můžu tě poprosit aby jsi ten tvůj kód vložil do toho mého. Asi to dělám nějak blbě.citovat
Richard99(19.2.2012 12:09)#007346
avatar
Zkusím to, ale pošli celý sešit, samotný kód nevyzkouším.citovat
marficek119(19.2.2012 12:21)#007347
avatar
Tady je soubor, snad se ti to povede.
Příloha: rar7347_export-faktura0k.rar (23kB, staženo 30x)
citovat
Richard99(19.2.2012 13:04)#007348
avatar
Mě ten tvůj sešit funguje tak, že zǔstane otevřený pǔvodní sešit, tak jak jsi chtěl, takže nevím co s tím.citovat
marficek119(19.2.2012 13:52)#007351
avatar
Momentálně to tak funguje, protože se zkopírují listy do nového sešitu. Ale já potřebuji, aby se vytvořila kopie sešitu, jelikož do tohoto dokumentu bude dávat ještě Userform, tak potřebuji, aby se kopie vytvořila i s Userform. Jinak bych to neřešilcitovat
Richard99(19.2.2012 18:22)#007353
avatar
Tak jsem poslal námět na řešení, ale nehodlám se ponořit do tvého problému.citovat
marficek119(19.2.2012 18:49)#007354
avatar
Nemám žádný problém, jen jsem chtěl pomoct. I tak dík. Snad pomůže někdo jiný.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