3 Probleme
26.04.2021 16:56:29
Eisi
ich dachte jetzt läuft alles, aber leider hakt es noch an folgenden Punkten:
1. Der Druckbereich besteht aus 1 - 19 Seiten ab B3:I und letzte Zeile. So wie ich den Code verstehe, wird auch nur dieser Bereich kopiert.
Das macht er aber nicht, wenn in der Spalte A etwas steht. Somit werden mir alle 19 Seiten als PDF gedruckt und in Excel kopiert, weil in Spalte A immer die
Seitenzahl steht. Warum ist das so?
2. Im Druckbereich steht Text usw., aber auch Bilder aus Hardcopy. Die Bilder werden in der PDF angezeigt, aber in der Excelmappe "AlleAngebote.xlsm" nicht.
Was muss am Code angepasst werden, damit alles kopiert wird?
3. Es wird immer der Blattschutz geöffnet und geschlossen. In der ersten Einstellung habe ich folgendes angehakt:
- Gesperrte Zellen auswählen
- Nicht gesperrte Zellen auswählen
- Objekte bearbeiten (Damit ich mit Hardcopy in den Druckbereich etwas einfügen kann)
Leider geht der Haken "Objekte bearbeiten" immer wieder raus.
Warum ist das so und wie kann man das ändern?
Vielen Dank für die Unterstützung.
VG Eisi :-)
Sub AngebotDrucken_2()
' PDF drucken
tbl_AngebotDrucken.Unprotect ("")
' Liegt ein Verzeichnis vor?
' Wenn nicht, dann lege eins an.
If Dir("C:" & "\Angebote", vbDirectory) = "" Then
MkDir "C:" & "\Angebote"
End If
' Angebotsnummer einstellen
Dim RechNr As Long
Dim Jahr As Integer
Dim ws As Worksheet
Dim DateiName As String
Set ws = ThisWorkbook.Worksheets("AngebotDrucken")
Jahr = ActiveWorkbook.BuiltinDocumentProperties(6)
RechNr = ActiveWorkbook.BuiltinDocumentProperties(5) ' Mit 4 auf Null setzen. Mit 5 hochzählen. (Mit 1 konnte ich auch schon mal auf Null stellen?
If Application.Dialogs(xlDialogPrinterSetup).Show = False Then Exit Sub
If Jahr Year(Date) Then
RechNr = 0
Jahr = Year(Date)
ActiveWorkbook.BuiltinDocumentProperties(6) = Jahr
End If
RechNr = RechNr + 1
ActiveWorkbook.BuiltinDocumentProperties(5) = RechNr
DateiName = Format(RechNr, "0000") & " - " & Jahr & " ! " & ws.Range("E1").Text
ws.Range("B4") = DateiName
'_________________________________________________________________________________________
' Seitenumbrüche entfernen
Dim i As Integer
With ActiveSheet
For i = .HPageBreaks.Count To 1 Step -1
.HPageBreaks(i).Delete
Next i
End With
' Seitenumbrüche setzen
Dim lngRow As Long
With ActiveSheet
For lngRow = 56 To .UsedRange.Rows.Count Step 55
.HPageBreaks.Add Before:=Cells(lngRow, 1)
Next lngRow
End With
'_________________________________________________________________________________________
' Drucken auf PDF
Dim DruckeAngebot As String
Dim LZeile As String
' Fehlermeldung abfangen
On Error Resume Next
DruckeAngebot = "C:\Angebote\" & DateiName & ".pdf"
'Suche die letzte befüllte Zeile
With ActiveSheet
LZeile = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlPrevious).Row
End With
'Seite formatieren
With ws.PageSetup
.Orientation = xlPortrait
.PrintArea = "$B$3:$I$" & LZeile
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
.PrintTitleRows = ""
.PrintTitleColumns = ""
.LeftFooter = DateiName
End With
'PDF drucken (PDFCreator wählen)
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DruckeAngebot, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
ActiveSheet.Range("A7").Select
'Passwortvergabe erfolgt hier nicht, erst nach **Call**
' tbl_AngebotDrucken.Protect ("")
Call AngebotInExcelCopy
End Sub
Public Sub AngebotInExcelCopy_2()
Dim wbkQuelle As Workbook
Dim wbkZiel As Workbook
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Dim rngCopy As Range
Dim Zeile_L As Long
Set wbkQuelle = Workbooks("AngebotsTool.xlsm")
For Each wbkZiel In Application.Workbooks
If LCase(wbkZiel.Name) = LCase("AlleAngebote.xlsm") Then
Exit For
End If
Next
If wbkZiel Is Nothing Then
Set wbkZiel = Workbooks.Open("C:\Angebote\AlleAngebote.xlsm")
End If
Set wksQuelle = wbkQuelle.Worksheets("AngebotDrucken")
With wksQuelle
Zeile_L = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rngCopy = .Range(.Cells(3, 2), .Cells(Zeile_L, 9))
End With
With wbkZiel
'neues Blatt am Ende einfügen
.Worksheets.Add After:=.Sheets(.Sheets.Count)
Set wksZiel = .Sheets(.Sheets.Count)
End With
With wksZiel
'Neues Blatt grau einfärben
.Cells.Interior.ColorIndex = xlNone
.Cells.Interior.ColorIndex = 15
End With
With wksZiel
rngCopy.Copy
With .Range("B3")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
.Name = Range("B4").Text
End With
'ZielDatei speichern
wbkZiel.Save
tbl_AngebotDrucken.Protect ("")
End Sub