Excel 2016 VBA Makro PDF Drucken läuft auf Fehler

[Phill__]

Hallo,

folgender Sachverhalt.

Wir haben eine Tabelle die Änderungen an Wartungsverträgen enthält und durch den Anwender selbst aktualisiert werden kann.
Eine Kollegin die nicht mehr im Unternehmen ist hat die Tabelle für die Anwender so vereinfacht das diese nur auf einen Knopf drücken müssen das sich diese Tabelle aktualisiert und je nach Niederlassung ein PDF in einen definierten Ordner abspeichert.

Die Datei läuft aber seit neustem auf einen Fehler:

Die Tabelle aktualisiert wohl die Daten und immer wenn die Daten einer Niederlassung aktualisiert wurden und ein PDF erstellt werden voll kommt der Laufzeitfehler.

Wäre Super wenn mir jemand helfen könnte das die blöde Tabelle wieder funktioniert.

Edit: hier das Makro bis zum Fehler:

Sub Generierung()

'Stellt die Bildschirmaktualisierung aus (Kein Flackern)
Application.ScreenUpdating = False

'Anzeigen des aktuellen Status unten links in der Statusleiste
Application.StatusBar = "Bearbeitung läuft..."


'Reiter Daten auswählen und Datenbasis aktualisieren
Sheets("Daten").Select
Range("A1").Select
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
Application.StatusBar = False


'alle Zeilen in Tabelle löschen, bei denen Spalte C nicht gefüllt ist
Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Reiter Daten Sortierung Spalte Neuvertrag
ActiveWorkbook.Worksheets("Daten").ListObjects("Tabelle_Abfrage_von_HSMP333"). _
Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Daten").ListObjects("Tabelle_Abfrage_von_HSMP333"). _
Sort.SortFields.Add Key:=Range( _
"Tabelle_Abfrage_von_HSMP333[[#All],[Neuvertrag]]"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Daten").ListObjects( _
"Tabelle_Abfrage_von_HSMP333").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Dublikate zur Bestimmung der NLs entfernen
Columns("A:A").Select
Selection.Copy
Sheets("Hilfen").Select
Columns("A:A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$A$100000").RemoveDuplicates Columns:=1, Header:=xlNo

'NL Aufstellung aufsteigend sortieren
Sheets("Hilfen").Select
Range("A2:A16").Select
ActiveWorkbook.Worksheets("Hilfen").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hilfen").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Hilfen").Sort
.SetRange Range("A2:A16")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Anzahl NL definieren
Anzahl = Range("C1")
Auswertungsmonat = Range("C2")

For i = 1 To Anzahl

Range("A1").Select
NL = ActiveCell.Offset(i, 0)

'Wechsel auf Reiter Daten
Sheets("Daten").Select

'Angaben zu Folgeaktion (bzw. -vertrag) für "Neuvertrag" und "Vertragsänderung" löschen
ActiveSheet.ListObjects("Tabelle_Abfrage_von_HSMP333").Range.AutoFilter Field _
:=2, Criteria1:="<>"
ActiveSheet.ListObjects("Tabelle_Abfrage_von_HSMP333").Range.AutoFilter Field _
:=11, Criteria1:="Neuvertrag", Operator:=xlOr, Criteria2:= _
"=Vertragsänderung"
Range("Tabelle_Abfrage_von_HSMP333[Folgeaktion]").Select
Selection.ClearContents
ActiveSheet.ListObjects("Tabelle_Abfrage_von_HSMP333").Range.AutoFilter Field _
:=11
ActiveSheet.ListObjects("Tabelle_Abfrage_von_HSMP333").Range.AutoFilter Field _
:=2

'Filter auf NL setzen (und Gesamtsummen rausnehmen)
ActiveSheet.ListObjects("Tabelle_Abfrage_von_HSMP333").Range.AutoFilter Field _
:=1, Criteria1:=NL, Operator:=xlAnd
'ActiveSheet.ListObjects("Tabelle_Abfrage_von_HSMP333").Range.AutoFilter Field _
:=3, Criteria1:="<>"

'Auswahl kopieren und in Tabellenblatt Auswertung einfügen
Range("A1:R10000").Select
Selection.Copy
Sheets("Auswertung").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'Neue verkürzte Kopf/Beschriftungszeile einfügen
Sheets("Hilfen").Select
Range("F1:W1").Select
Selection.Copy
Sheets("Auswertung").Select
Range("A4").Select
ActiveSheet.Paste

'Neue Konditionsvereinbarung benennen
Sheets("Auswertung").Select
LetzteZeile = Range("R1000000").End(xlUp).Row

Range("T5").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-19]="""","""",IF(RC[-17]=""Prüfung und Wartung Komfort"",""Prüfung und Wartung"",IF(RC[-17]=""Einmal-Wartung"",""Einmal-Wartung"",MID(RC[-17],24,100))))"
Range("T5").Select
Selection.Copy
Range("T5:T" & LetzteZeile).Select
ActiveSheet.Paste

'neue Konditionsvereinbarung in Zeile C einfügen
Range("T5:T" & LetzteZeile).Select
Selection.Copy
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

'Werte aus Zeile T löschen
Columns("T:T").Select
Selection.ClearContents

'Umwandlung als Text gespeicherte Zahl in eine Zahl umwandeln
For x = 5 To LetzteZeile
Cells(x, 16) = CLng(Cells(x, 16))
Cells(x, 16).NumberFormat = "General"
Cells(x, 17) = CLng(Cells(x, 17))
Cells(x, 17).NumberFormat = "General"
Cells(x, 18) = CLng(Cells(x, 18))
Cells(x, 18).NumberFormat = "General"
Next

Range("E5").Select


'Teilergebnisse für die Spalten Anlagenanzahl alt, neu, Differenz nach Merkmal Neuvertrag bilden
Selection.Subtotal GroupBy:=11, Function:=xlSum, TotalList:=Array(16, 17, 18) _
, Replace:=True, PageBreaks:=False, SummaryBelowData:=True


'Formel für die Bedingte Formatierung einfügen, da diese sonst in den Ergebnisspalten nicht da ist
Ende_NEU = LetzteZeile + 4

Range("S5").Select
ActiveCell.FormulaR1C1 = _
"=IF(NOT(ISERROR(FIND(""Gesamtergebnis"",RC[-8]))),""XX"",IF(NOT(ISERROR(FIND(""Ergebnis"",RC[-8]))),""X"",""""))"
Range("S5").Select
Selection.Copy
Range("S6:S" & Ende_NEU).Select
ActiveSheet.Paste

'Zeilenumbruch für Spalte M (Bemerkung) einfügen
Columns("M:M").Select
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A5:R" & LetzteZeile).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


'Datei als PDF abspeichern
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"T:\Service-Zentrale\Projekt-HSM\Statistik\Auswertungen Änderung P&W Verträge\" & NL & "\Änderung P&W Anlagenbestand " & NL & " - " & Auswertungsmonat & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

 

[burglar225]

So wird dir hier vermutlich niemand helfen können. Eine einzelne Zeile des Codes ist sinnfrei. Evtl. hast du Glück und das ist ein bekannter Fehler, aber die Meldung oben ist auch nicht besonders aussagekräftig, ich schätze also eher nein.
Die Frage, die sich mir stellt ist aber erstmal eine andere. Es hat ja die ganze Zeit wohl funktioniert, was hat sich jetzt also geändert, dass es nicht mehr funktioniert?

 

[Phill__]

Ich kann gerne alles Posten das ist nicht das Thema dachte das es o übersichtlicher ist. Was sich verändert hat nichts ausser den ganz normalen Office Updates.

 

[G-Red]

Ist der Gelbmarkierte Codeabschnitt der, nach dem die Fehlermeldung auftaucht?

 

[burglar225]

Prinzipiell kann ich auf die schnelle kein Problem sehen, was aber überhaupt nichts zu heißen hat. Ich kann (und will) hier jetzt nicht im Detail den Code analysieren, zumal ich den Fehler eh nicht im Code vermute.
In der von dir angegebenen Anweisung wird eine PDF-Datei im Dateisystem erstellt. Hast du geprüft, ob der Pfad, auf den Zugegriffen wird, existiert und, ob Schreibberechtigungen bestehen?

Ergänzung (9. April 2020)

@G-Red Sieht ganz so aus, der Debugger steht ja an der Stelle.

 

[G-Red]

Hast du geprüft, ob der Pfad, auf den Zugegriffen wird, existiert und, ob Schreibberechtigungen bestehen?

Das wäre auch meine Vermuttung, dass der Pfad nicht mehr so heißt oder gar existiert. Wollte es halt nur genau wissen, wegen der Gelbmarkierung.

 

[Phill__]

Also die gelbe Markierung ist der Punkt an dem das makro abbricht. Ja die Pfade sind korrekt und uahc vorhanden. Ich habe mal mit meinen geringen VBA Kentnissen geschaut und konnta auch nichts finden z.B. der komplette gelbe beriech wurde von einer Microsoft Support seite so übernommen da wurde nichts selbst geschrieben.

 

[G-Red]

Kannst du den unter dem angegebenen Pfad selbst was erstellen? Probier da einfach eine Textdatei zu erstellen, es könnte nämlich sein dass die Schreibrechte in den Ordnern verändert worden sind.

 

[Phill__]

Gute Idee aber leider geht es

 

[Sun_set_1]

Das Problem ist halt, das in dem Pfad auch zig Strings verarbeitet werden, die vorher durch die Prozedur erstellt werden. Theoretisch kann also jeder dieser Strings den Pfad korrumpieren. Einfachste Möglichkeit wäre den Pfad mal testweise auf den eigenen Desktop zu ändern und höchsten die String-Variable beim Dateinamen drinnen lassen. Wenns dann geht liegt’s entweder an Berechtigungen oder eben einem defekten String. Nur den ohne Beispieldateien und richtiger Umgebung zu finden, kannste fast vergessen.

 

[AwesomSTUFF]

Hast Du mal nen "einfachen" Pfad wie einfach nur T:\Test probiert um auszuschließen, dass der Fehler im Pfad/ irgendwelchen Zeichen selbst liegt?

 

[Phill__]

werde glich mal den Pfad ändern Guter Tip!

 

[G-Red]

Ersetze mal diesen Code

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"T:\Service-Zentrale\Projekt-HSM\Statistik\Auswertungen Änderung P&W Verträge\" & NL & "\Änderung P&W Anlagenbestand " & NL & " - " & Auswertungsmonat & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

durch diesen. Das speichert dir die Datei TEST.pdf auf deinen Desktop

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Environ("USERPROFILE") & "\Desktop\TEST.pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

 

[Sun_set_1]

'Anzahl NL definieren
Anzahl = Range("C1")
Auswertungsmonat = Range("C2")

For i = 1 To Anzahl

Range("A1").Select
NL = ActiveCell.Offset(i, 0)

'Datei als PDF abspeichern
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"T:\Service-Zentrale\Projekt-HSM\Statistik\Auswertungen Änderung P&W Verträge\" & NL & "\Änderung P&W Anlagenbestand " & NL & " - " & Auswertungsmonat & ".pdf",

Habt ihr eventuell eine Niederlassung in den Stammdaten, die Sonderzeichen enthält, oder sonstwie komisch benannt ist? Sind eventuell Leerwerte vorhanden? Sprich leere Zellen. Laut Code sollten entfernt werden, aber sowas knallt gerne mal.

 

[Phill__]

@G-Red "Userprofile" da muss mein User rein korrekt?

Ergänzung (9. April 2020)

@Sun_set_1 nein die Niederlassungen sind alle gleich z.b. N11 N12 ....

 

[G-Red]

@G-Red "Userprofile" da muss mein User rein korrekt?

Nein, das ist die Windows Umgebungsvariable, die deinen Benutzer bereits enthält. Du musst da nichts ändern. Ich habe allerdings grad nen kleinen Fehler im Code korrigeirt, daher guck es dir noch mal an.

 

[Sun_set_1]

@G-Red "Userprofile" da muss mein User rein korrekt?

Ergänzung (9. April 2020)

@Sun_set_1 nein die Niederlassungen sind alle gleich z.b. N11 N12 ....

Auf dem Hauptblatt müsste ne Spalte sein (glaub A) die die Niederlassungen enthält, wenn ich den Code richtig lese. Diese Spalte mal auf komische Einträge prüfen, nachdem der Code geknallt hat (müsste im Hintergrund offen sein)

 

[Phill__]

@G-Red okay das hat funktioniert jetzt hängt er beim nachfolgenden Teil:
'Ablage der PDFs in SKO-Ordner
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"T:\Service-Zentrale\Regionalleiter ST\Statistiken\Auswertung Änderungen P&W Verträge\" & NL & "\Änderung P&W Anlagenbestand " & NL & " - " & Auswertungsmonat & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Ich würde jetzt vermuten das es wirklich ein Problem mit den Ordnern gibt oder ?

Ergänzung (9. April 2020)

@Sun_set_1 die Daten werden jedesmal per SQL aus der Datenbank geholt. In der Tabelle befinden sich nur die E-mail Adressen der Personen die das per Mail bekommen sollen.

 

[G-Red]

Due kannst den Pfadteil durch den ersetzen den ich davor gezeigt habe. Allerdings denke ich, es hängt nicht an dem Speicherort, sondern tatsächlich an den Daten. Kannst du vielleicht vor der genannten Zeile Code,

Debug.Print NL

eintragen und den Inhalt posten?

 

[Phill__]

So korrekt? läuft immer auf den gleichen Fehler

Debug.Print NL
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"T:\Service-Zentrale\Regionalleiter ST\Statistiken\Auswertung Änderungen P&W Verträge\" & NL & "\Änderung P&W Anlagenbestand " & NL & " - " & Auswertungsmonat & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False