< návrat zpět

MS Excel


Téma: Nefunkční ScreenUpdating rss

Zaslal/a 9.3.2012 20:38

Zdravím, můžete se někdo mrknout na tento kód a poradit proč nefunguje Application.ScreenUpdating = False v tomto kódu?
Mám úplně stejně řešený kód pro export dalšího listu a v tom to funguje normálně. Jsem z toho jelen a netuším, proč to nejde, nebo že by nějaká chyba v Excelu? Díky

Sub Export_do_databaze2()
Application.ScreenUpdating = False
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 Faktury

doDB = True
ActiveWorkbook.Save

' nastavení cesty pro uložení dat - tam kde byl původní sešit otevřen
cesta = ActiveWorkbook.Path
Application.DisplayAlerts = False
Application.ScreenUpdating = False
c_Faktury = Worksheets("Faktura").Cells(14, 20).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 faktura existuje, chcete přesto provést export?", vbYesNo, "Faktura 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ž fakturu
' zkopíruje celý list "Faktura" do nového sešitu
awb_name = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name




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

nove_jmeno = c_Faktury & "" ' 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
' Skrytí nepotřebných listů
Sheets("Menu").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Databáze nabídek").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Databáze faktur").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Nabídka").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Faktura nabídka").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Příjmový doklad").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Faktura bez položek").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Příjmový doklad BP").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("PV Nabídka").Select
ActiveWindow.SelectedSheets.Visible = False

Worksheets("Faktura").Activate
Sheets("Faktura").Unprotect Password:="RD8110" 'Odemkne list
ActiveSheet.Shapes("TLExport2").Delete
Sheets("Faktura").Protect Password:="RD8110" 'Zamkne list
' uložení sešitu do standadní cesty ukládání
ActiveWorkbook.SaveAs (cele_jmeno)

' zavření nově vytvořeného sešitu
awb2_name = ActiveWorkbook.Name
Workbooks.Open filename:=awb_name

'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("Faktura").Range("K10") 'Jméno
Worksheets("Databáze faktur").Cells(radek, 4) = Worksheets("Faktura").Range("M20") 'Datum vystavení
Worksheets("Databáze faktur").Cells(radek, 5) = Worksheets("Faktura").Range("M19") 'Datum Splatnosti
Worksheets("Databáze faktur").Cells(radek, 6) = Worksheets("Faktura").Range("M183") 'Částka
Worksheets("Databáze faktur").Cells(radek, 2).Formula = "=hyperlink(""" & cele_jmeno & """,""" & c_Faktury & """)"
End If
Windows(awb2_name).Close
Unload Priprava_na_export
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

stop Uzamčeno - nelze přidávat nové příspěvky.

#007588
avatar
Nevím jak to myslíš, ale spíš funguje až moc. Tvoje makro skončí a nenaběhne aktualizování obrazovky a ty asi sejmeš Excel a spustíš jej znovu ??? Pokud mám pravdu pak se podívej kolikrát jsi zapnul obnovení obrazovky !!! Pokaždé, když dáš Exit Sub pak před to musíš dát displAlerts, screnUpd atd. Nejjednodužší je dát návěští před konec a všechny exit sub nahradit přískokem vpřed. Pokud je Tvůj případ opačný, tj. že Ti nenaběhne vypnutí překreslování GUI pak promiň. Je toto zbytečná připomínka. R.citovat
#007594
avatar
Ne zcela jsem tvoji odpověď pochopil. ScreenUpd nefunguje vůbec v tomto kódu. Ale nechápu proč funguje v jiném kódu který je úplně stejně napsaný (rozdíl je jen v názvu listů které se vyskytují v kódu)citovat
#007599
avatar
Vyřešeno. Problém byl v listu který byl exportován nikoliv kódu.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