< návrat zpět
MS Excel
Téma: Nefunkční ScreenUpdating 
Zaslal/a marficek119 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
Uzamčeno - nelze přidávat nové příspěvky.
RomanNTA(10.3.2012 20:37)#007588 
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.
citovatNe 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)
citovatVyřešeno. Problém byl v listu který byl exportován nikoliv kódu.
citovat
RSS nejnovější články