ProgressBar
15.03.2020 17:48:02
Mike
Wieder das alte Problem.
Das Abspeichern einer Exceldatei als PDF dauert bis zu 4 Minuten, da wäre eine Anzeige als Fortschrittsbalken
behilflich. Meine Versuche sind fehlgeschlagen. Vielleicht weiß jemand Rat wie das Einzubauen ist.
Hier der Code:
Sub Werte_Drucken()
'speichert das Ergebnis der Wertermittlung inkl. Anlage als PDF-Datei
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim boolSpeichervorgang As Boolean
Dim dtKennwort As String
dtKennwort = "1"
For Each ws In Worksheets
ws.Unprotect Password = dtKennwort
Next ws
Fusszeile_einstellen
If MsgBox("Bitte bestätigen Sie mit 'Ja' wenn das Ergebnis der Werte inklusive Anlage als PDF- _
_
Datei im aktuellen Ordner gespeichert werden soll. Der Vorgang wird einige Minuten dauern. Sie _
erhalten eine Bestätigung nach dem Speichervorgang.", vbYesNo, "PDF-Dateien speichern?") = vbYes Then
Sheets("Ergebnis").Select
Range("D1").Select
Selection.Interior.ColorIndex = 0 'keine Farbe
Selection.Font.ColorIndex = 2 'keine Farbe
Sheets("Anlage").Select
Range("H1").Select
Selection.Interior.ColorIndex = 0 'keine Farbe
Selection.Font.ColorIndex = 2 'keine Farbe
Range("J1:M1").Select
Selection.Interior.ColorIndex = 0 'keine Farbe
Selection.Font.ColorIndex = 2 'keine Farbe
Application.GoTo Reference:="Eingabe_14"
Selection.Interior.ColorIndex = 0 'keine Farbe
Range("A1").Select
Anlage_Zeilen_ausblenden
' Code für die Druckfunktion - ausgeschaltet seit der PDF-Funktion
' ActiveWindow.ScrollWorkbookTabs Sheets:=-1
' Sheets("Ergebnis").Select
' Sheets("Ergebnis").Activate
' With ActiveSheet.PageSetup
' .Orientation = xlPortrait
' End With
' ActiveWindow.SelectedSheets.PrintOut Copies:=1
' Sheets("Anlage").Select
' Sheets("Anlage").Activate
' With ActiveSheet.PageSetup
' .Orientation = xlLandscape
' End With
' ActiveWindow.SelectedSheets.PrintOut Copies:=1
Speichern_als_PDF_Datei
Sheets("Übersicht").Select
Range("D15").Select
boolSpeichervorgang = True
Else
boolSpeichervorgang = False
End If
For Each ws In Worksheets
ws.Unprotect Password = dtKennwort
Next ws
Sheets("Ergebnis").Select
Range("D1").Select
Selection.Interior.Color = 15073253
Selection.Font.Color = -16751104
Application.GoTo Reference:="Eingabe_14"
Selection.Interior.Color = 15073253
Range("A1").Select
Sheets("Anlage Wertermittlung").Select
Range("H1").Select
Selection.Interior.Color = 15073253
Selection.Font.Color = -16751104
Range("J1:M1").Select
Selection.Interior.Color = 15073253
Selection.Font.Color = -16751104
Sheets("Ergebnis").Select
Range("D1").Select
Schutz_aktivieren
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If boolSpeichervorgang = True Then
MsgBox "Die Werte und die Anlage zur Wertvoll wurden als PDF-Dateien im aktuellen Ordner _
gespeichert.", vbInformation, "PDF-Dateien gespeichert"
Else
MsgBox "Der Vorgang wurde abgebrochen", vbInformation, "Vorgang abgebrochen"
End If
End Sub
Sub Fusszeile_einstellen()
Sheets("Anlage").Select
ActiveSheet.PageSetup.CenterFooter = "&""Tahoma,Standard""&8" & Sheets("Anlage _
Wertermittlung").Cells(4, 15).Value
Sheets("Ergebnis").Select
ActiveSheet.PageSetup.CenterFooter = "&""Tahoma,Standard""&8" & Sheets("Anlage _
Wertermittlung").Cells(4, 15).Value
End Sub
Sub Anlage_Zeilen_ausblenden()
'alle Zeilen mit einem "0" in Spalte "N" ausblenden
Fusszeile_einstellen
Sheets("Anlage").Select
Rows("14:695").Select
Selection.EntireRow.Hidden = False
Range("N14").Select
For i = 14 To 695
Range("O" & i).Select
If ActiveCell.Value = 0 Then
Rows(i & ":" & i).Select
Selection.EntireRow.Hidden = True
Else
Rows(i & ":" & i).Select
Selection.EntireRow.Hidden = False
End If
Next i
Range("A1").Select
End Sub
Sub Speichern_als_PDF_Datei()
'Dim strDateiName As String
Dim strVerein As String
Dim strGartenNr As String
Dim strPaechter As String
Dim strDatum As String
Sheets("Ergebnis").Select
Range("D7").Select
strVerein = ActiveCell.Value
Range("B6").Select
strGartenNr = ActiveCell.Value
Range("C9").Select
strPaechter = ActiveCell.Value
Range("C10").Select
strDatum = Day(ActiveCell.Value) & "-" & Month(ActiveCell.Value) & "-" & Year(ActiveCell.Value)
strDateiName = CurDir
strDateiName = strVerein & " - Ga " & strGartenNr & " - " & strPaechter & " - " & strDatum & " - _
_
Wertermittlung.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strDateiName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Sheets("Anlage ").Select
Range("B6").Select
strDateiName = CurDir
strDateiName = strVerein & " - Ga " & strGartenNr & " - " & strPaechter & " - " & strDatum & " - _
_
We.Anlage.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strDateiName, Quality _
:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub