Rahmenfarbe nicht mitdrucken

Hallo zusammen,

ich möchte in einer Mappe alle eingeblendeten Tabellenblätter drucken (entweder über die Funktion Veröffentlichen als PDF oder Str+P...). Dabei sollen in allen Tabellenblättern die Rahmenfarben hellblau und orange nicht mit gedruckt werden. Ich habe auch hierzu ein Code gefunden, der für ein Tabellenblatt die Rahmenfarbe schwarz entfernt und wieder einsetzt.

Könnte jemand mir behilflich sein und den Code so umschreiben, dass ...
A) ...die Rahmenfarben hellblau und orange in allen eingeblendeten Tabellenblättern beim Druck entfernt und wieder eingesetzt werden? Hierzu soll jeweils der Blattschutz aufgehoben und wieder eingesetzt werden vor dem Druck eines Tabellenblattes. Alle Blätter haben das gleiche Kennwort zum Aufheben des Blattschutzes.
B) ...das Drucken über beide Funktionen (Veröffentlichen als PDF und Str+P...) funktioniert?

Danke für die Hilfe.

Hier der Code:

Private Sub Workbook_BeforePrint(Cancel As Boolean)

Dim c As Range
On Error GoTo ERRHANDLER
Application.ScreenUpdating = False
Application.EnableEvents = False
'Rahmen weiß
For Each c In ActiveSheet.UsedRange
If c.Borders.LineStyle > -4142 Then c.Borders.ColorIndex = 2
Next
ActiveSheet.PrintOut
Cancel = True
'Rahmen wieder schwarz
For Each c In ActiveSheet.UsedRange
If c.Borders.LineStyle > -4142 Then c.Borders.ColorIndex = 1
Next
ERRHANDLER:
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
 Dim z As Long, s As Long, c As Range
 Dim iArr() As Long
 
 On Error GoTo ERRHANDLER
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 
 ActiveSheet.Unprotect
 With ActiveSheet.UsedRange
     z = .Rows.Count
     s = .Columns.Count
     ReDim iArr(z, s)
 End With
 
 For Each c In ActiveSheet.UsedRange
     If c.Borders.LineStyle > -4142 And _
       (c.Borders.ColorIndex = 3 Or c.Borders.ColorIndex = 4) Then 'anpassen
        iArr(c.Row, c.Column) = c.Borders.ColorIndex
        c.Borders.ColorIndex = 2
     Else
        iArr(c.Row, c.Column) = 99
     End If
 Next c
 ActiveSheet.PrintOut
' Cancel = True
 For Each c In ActiveSheet.UsedRange
     If iArr(c.Row, c.Column) < 99 Then
        c.Borders.ColorIndex = iArr(c.Row, c.Column)
     End If
 Next c
ERRHANDLER:
 ActiveSheet.Protect
 Application.EnableEvents = True
 Application.ScreenUpdating = True
End Sub

Code:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
 Dim c As Range, iArr() As Long
    
 With ActiveSheet
    .Unprotect
    With .UsedRange
       ReDim iArr(.Row + .Rows.Count, .Column + .Columns.Count)
    End With
    
    On Error Resume Next
    For Each c In .UsedRange
        With c.Borders
           iArr(c.Row, c.Column) = .ColorIndex
           If .ColorIndex = 3 Or .ColorIndex = (-4105) Then .ColorIndex = 2
        End With
    Next c
    
    ActiveSheet.PrintOut
'   Cancel = True

    For Each c In .UsedRange
        If iArr(c.Row, c.Column) = 3 Or iArr(c.Row, c.Column) = (-4105) Then
           c.Borders.ColorIndex = iArr(c.Row, c.Column)
        End If
    Next c
    .Protect
 End With
End Sub

Code:

Option Explicit

Private Type Data_STRUCT
   sPar As String
   sAdr As String
   iCol As Integer
End Type
Dim tData() As Data_STRUCT

Private Sub Workbook_BeforePrint(Cancel As Boolean)
  Dim i As Long, x As Integer
  Dim c As Range
  Dim iVon As Integer, iBis As Integer
 
  Application.EnableEvents = False
  
  iVon = 1
  iBis = 2 'ThisWorkbook.Worksheets.Count
  
  For x = iVon To iBis
      ThisWorkbook.Sheets(x).Unprotect
' Daten sichern
      For Each c In ThisWorkbook.Sheets(x).UsedRange
          With c.Borders
             If .ColorIndex = 3 Or .ColorIndex = (-4105) Then
                ReDim Preserve tData(i)
                tData(i).iCol = .ColorIndex
                tData(i).sAdr = c.Address
                tData(i).sPar = c.Parent.Name
                .ColorIndex = 2
                i = i + 1
             End If
          End With
      Next c
  Next x
  
' Drucken
  ActiveWorkbook.PrintOut from:=iVon, To:=iBis
  Cancel = True
 
' Rahmen wiederherstellen
  For i = 0 To UBound(tData)
      Sheets(tData(i).sPar).Range(tData(i).sAdr).Borders.ColorIndex = tData(i).iCol
  Next i
  
  For x = iVon To iBis
      ThisWorkbook.Sheets(x).Protect
  Next x
  
  Application.EnableEvents = True
End Sub

Code:

Option Explicit

Private Type Data_STRUCT
   sPar As String
   sAdr As String
   iCol As Integer
End Type
Dim tData() As Data_STRUCT

Private Sub Workbook_BeforePrint(Cancel As Boolean)
  Dim i As Long, x As Integer
  Dim c As Range
  Dim iVon As Integer, iBis As Integer
 
  Application.EnableEvents = False
  
  iVon = 1
  iBis = ThisWorkbook.Sheets.Count
  
  For x = iVon To iBis
      If Sheets(x).Visible = True Then
         Sheets(x).Unprotect
' Daten sichern
         For Each c In Sheets(x).UsedRange
             With c.Borders
                If .ColorIndex = 3 Or .ColorIndex = (-4105) Then
                   ReDim Preserve tData(i)
                   tData(i).iCol = .ColorIndex
                   tData(i).sAdr = c.Address
                   tData(i).sPar = c.Parent.Name
                   .ColorIndex = 2
                   i = i + 1
                End If
             End With
         Next c
      End If
  Next x
' Drucken
  ActiveWorkbook.PrintOut from:=iVon, To:=iBis
  Cancel = True
 
' Rahmen wiederherstellen
  For i = 0 To UBound(tData)
      Sheets(tData(i).sPar).Range(tData(i).sAdr).Borders.ColorIndex = tData(i).iCol
  Next i
  
  For x = iVon To iBis
      If Sheets(x).Visible = True Then Sheets(x).Protect
  Next x
  
  Application.EnableEvents = True
End Sub

Hi
mal ein anderer Ansatz, der etwas vorbereitung erfordert, aber sehr flexibel ist:

1. kopiere dir diese Funkion in ein allgemeines Modul:

Function RahmenAus(Zelle As Range, Seite As String, farben As Range) As Boolean
Dim S As Long
Dim rF As Range
Select Case LCase(Left(Seite, 1))
    Case "o": S = xlEdgeTop
    Case "u": S = xlEdgeBottom
    Case "l": S = xlEdgeLeft
    Case "r": S = xlEdgeRight
End Select

For Each rF In farben.Cells
    If Zelle.Borders(S).Color = rF.Interior.Color Then Exit For
Next

RahmenAus = Not (rF Is Nothing)
die Formel ergibt WAHR, wenn die im ersten Parameter angegebene Zelle der Rahmen der Seite, die im zweiten Parameter angegeben ist (mit l, r, o, u, kann aber auch ausgeschrieben werden) eine Farbe hat, die eine der im dritten Parameter angegebenen Zellen als Hintergrundfarbe hat)
End Function

2. Lege ein neues Tabellenblatt an, nenne es beispielsweise "Druckeinstellung".
in diesem Blatt resevierst du eine Zelle , mit der du steuerst, ob das Ausblenden der Rahmenlinien aktiv sein soll oder (beispielsweise in dem du "ja" oder "nein" reinschreibst. diese Zelle sei A1
färbe nun auf dem Blatt Druckeinstellung jeweils eine Zelle mit der Farbe ein, die ausgeblendet werden soll, hier die Hintergrundfarbe. Die Zellen müssen direkt untereinanderliegen, beispielsweise die Zellen A2:A3

3. auf jedem Blatt, auf dem das wirksam sein soll musst du jetzt für den genutzten Zellbereich (Ab A1 bis letzte genutzte Zelle) vier bedingte Formatierungen anlegen (für jede Rahmenseite eine)
mit folgender Regel als Formel:

=UND(Druckeinstellung!$A$1:="ja";RahmenAus(A1;"o";Druckeinstellung!$A$2:$A$3))
=UND(Druckeinstellung!$A$1:="ja";RahmenAus(A1;"u";Druckeinstellung!$A$2:$A$3))
=UND(Druckeinstellung!$A$1:="ja";RahmenAus(A1;"l";Druckeinstellung!$A$2:$A$3))
=UND(Druckeinstellung!$A$1:="ja";RahmenAus(A1;"r";Druckeinstellung!$A$2:$A$3))

als Format blendest du dann die jeweilige Rahmenlinie aus (doppelt draufklicken, bis sie ganz verschwunden ist) (u =unten, o = oben, l = links, r = rechts)

das müsstest du für jede Seite einrichten.

dann kannst du die Rahmenlinien einfach ausblenden, in dem du in die Zelle A1 auf Druckeinstellung ein "ja" einträgst (das kannst du im BeforePrint ja einfach tun)
Vorteil ist, dass du die eigentlichen Formatierungen hierbei nicht änderst und damit auch nicht wieder herstellen musst.

du solltest auch für die Zellbereiche auf dem Blatt Druckeinstellung für den Zellbereich mit den Farben einen Namen anlegen und diesen in den Formeln der Bedingten Formatierung verwenden. Das macht es einfacher, wenn sich der Bereich mal ändert, weil Farben wegfallen oder hinzukommen, denn dann musst du nur den Namen anpassen, aber nicht die Formeln

Gruß Daniel

Option Explicit Dim wbSicherung As Workbook Sub FormateSichernUndLöschen() Dim alt As Long Dim i As Long Dim Zelle As Range Dim b As Long alt = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = ThisWorkbook.Sheets.Count ThisWorkbook.Activate Set wbSicherung = Workbooks.Add For i = 1 To ThisWorkbook.Worksheets.Count With ThisWorkbook.Sheets(i) .Cells.Copy wbSicherung.Sheets(i).Cells(1, 1).PasteSpecial xlPasteFormats For Each Zelle In .UsedRange For b = 7 To 10 With Zelle.Borders(b) Select Case .Color Case vbRed, vbGreen .LineStyle = xlNone Case Else End Select End With Next Next End With Next Application.SheetsInNewWorkbook = alt End Sub Sub FormateRekontruieren() Dim i As Long For i = 1 To ThisWorkbook.Worksheets.Count wbSicherung.Worksheets(i).Cells.Copy ThisWorkbook.Sheets(i).Cells(1, 1).PasteSpecial xlPasteFormats Next Application.CutCopyMode = False wbSicherung.Close False End Sub

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Rahmenfarbe nicht mitdrucken

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread