Excel vba Blockweise Formatierung

[sharky51]

Hallo zusammen,

darf ich Euch mal wieder um Eure werte Hilfe bitten?

In einer immer weiterwachsenden Datentabelle trage ich einer Spalte ("N") einen Status des entsprechenden Datensatzes ein, z.B. neu, offen, OK.
Datensätze aus der gleichen Kategorie stehen immer untereinander und sind in einem Block zusammengefasst. Der Block beginnt jeweils mit einer Überschrift und endet mit einer Leerzeile.
Nach der Leerzeile beginnt dann der nächste Block usw....... Die Überschriftenzeile ist farblich hervorgehoben, die Leerzeile dagegen nicht.

Da die Tabelle hunderte von Zeilen und Datensätze haben kann, will ich der Übersichtlichkeit halber, alle Datensätze die komplett den Status "OK" haben ausblenden können.....und zwar komplett mit seiner Überschrift und der Leerzeile nach dem Datenblock. Befindet sich innerhalb eines Datensatzes noch ein Element, das den Status "neu" oder "offen" hat, soll der Datensatz nicht ausgeblendet werden. Bisher habe ich das quasi manuell gelöst indem ich über ein Makro den Datenblock in der entsprechenden Zelle mit "Headder" und "Space" gekennzeichnet habe.
Anhand dieser "Marker" habe ich dann die entsprechenden Zeilen ausgeblendet siehe Makro 2.

Nun meine Frage, wie könnte ich speziell die Beschriftung komplett automatisieren, nur wenn alle Datensätze in einem Block den Status "OK" haben?
Am Beginn eines Datenblockes mit seiner blauen Zeile soll "Headder" und am Ende in die leere Zelle soll "Space" eingetragen werden.

Das sieht dann so aus wie in der beigefügten Datei ersichtlich.

Code:

'Spalte 14 "N" beschriften
Private Sub CommandButton4_Click()
  xCol = ActiveCell.Column
  xRow = ActiveCell.Row
 
  If ActiveCell.Column <> 14 Then
      Cells(xRow, 14).Select
  End If
 
  'Wenn Zelle "Blau"
  If ActiveCell.Interior.ColorIndex = 23 Then
      ActiveCell.Value = "Headder"
      xRow = ActiveCell.Row + 1
      Cells(xRow, 14).Select
      'Wenn Zelle ohne Farbe
  ElseIf ActiveCell.Interior.ColorIndex = -4142 Then
      ActiveCell.Value = "Space"
      'Cells(xRow, 14).Select
      xRow = ActiveCell.Row + 1
      Cells(xRow, 14).Select
  Else
      xRow = ActiveCell.Row
      xRow = ActiveCell.Row + 1
      Cells(xRow, 14).Select
      Exit Sub
  End If
End Sub

Makro 2:

Code:

'Alle Zeilen mit bestimmtem Zellinhalt ausblenden
Sub Spezielle_Zeilen_ausblenden()
  Application.ScreenUpdating = False
 
  'Hier wir die letzte Zeile der Spalte A ermittelt
  letzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
  'MsgBox letzteZeile
 
  For i = 6 To letzteZeile
      If Cells(i, 14).Value = "OK" Or Cells(i, 14).Value = "Headder" Or Cells(i, 14).Value = "Space" Then
        Rows(i).Hidden = True
      End If
  Next i
  Application.ScreenUpdating = False
End Sub

[Klaus-Dieter]

Hallo,

leider entspricht deine Liste nicht den Vorgaben vo Excel, sonst wäre das ganz einfach mit dem Autofilter zu lösen. Zwischenüberschriften und Leerzeilen gehören da nicht rein.

[sharky51]

Klaus-Dieter,

nun ja, das ist mir schon bewusst.

Leider komme ich um die Zwischenüberschriften nicht herum.
Das Ausblenden nur der der OK-Datenblöcke würde reichen.
Auf die Leerzeilen könnte ich natürlich auch verzichten.... sind nur bei allen eingeblendeten Zeilen für die Übersichtlichkeit schön zu haben.

[volti]

Hallo Sharky,

wenn Du konsequent mit den Farben arbeitest und nur die Blöcke (von Überschrift bis Leerzeile) ein bzw. ausblenden möchtest, kannst Du gerne mal u.a. Code testen.
Da brauchst Du auch Deine Headder- und Space-Angaben nicht.

PS: Leider hattest Du zwei Hintergrundblaus verwendet, sollte nicht sein, aber das kann das Tool ja auch trotzdem. 
Den Option Compare Text bitte als erstes im Modul platzieren.

Code:

Option Compare Text

Sub Spezielle_Zeilen_ausblenden_Neu()
 Dim iZeile As Long, WSh As Worksheet
 Dim sBer As String, bCheck As Boolean
 
 Application.ScreenUpdating = False
  
 Set WSh = ActiveSheet
 
 For iZeile = 6 To WSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    With WSh.Cells(iZeile, "N")
      Select Case .Interior.Color
      Case 13395456, 12611584                                      'blau Headerzeile
        sBer = .Address: bCheck = True
      Case 16777215                                                'weiß Leerzeile
        WSh.Range(sBer & ":" & .Address).EntireRow.Hidden = bCheck 'Bereich ausblenden
      Case 5287936                                                 'grün Abschluss
        Exit For
      Case Else
        If Not .Value Like "OK" Then bCheck = False                'Zustand merken
      End Select
    
    End With
 
 Next iZeile
    
 WSh.Range("N2").Value = "Anzahl offener Befunde: "
 WSh.Range("I2:O2").Interior.ColorIndex = 6
 WSh.Range("I2:O2").Font.ColorIndex = 3
 WSh.Range("A1").Select
 
 Application.ScreenUpdating = True

End Sub

____________________

viele Grüße aus Freigericht
Karl-Heinz

[sharky51]

Hallo Karl-Heinz,

extrem cool, vielen Dank und so kurz und knackig!!!!!

Eine Frage hätte ich aber noch.

Wie können die "alle" grünen Zeilen ausgeblendet werden und nicht nur komplett abgeschlossene Blöcke?
In Deinem Beispiel werden die Zeilen mit Test 5,6 & 9 nicht ausgeblendet, sollten aber.

Hast Du da noch einen Lösungsansatz und wie komme ich auf Case-Definitionen der Zellfarben?

[volti]

Hallo Sharky,

wenn alle grünen OK-Zeilen ebenfalls immer ausgeblendet werden sollen, braucht es nur eine kleine Modifikation.
Allerdings musste ich jetzt auch das Ein-Schalten wieder rausnehmen, so dass jetzt nur noch ausgeblendet wird.

PS: Die grünen OK-Zeilen werden jetzt auch über die Farbe ausgeblendet, egal ob da ok steht oder nicht.
Auch das kann man ändern aber bei konsequenter Anwendung dürfte in jeder grünen Zeile ja nur ok stehen...

Die Zellfarben habe ich einmalig mit u.a. Makro im Direktbereich ausgeben lassen....

Code:

Option Compare Text

Sub Spezielle_Zeilen_ausblenden_Neu()
 Dim iZeile As Long, WSh As Worksheet
 Dim sBer As String, bCheck As Boolean
 
 Application.ScreenUpdating = False
  
 Set WSh = ActiveSheet
 
 For iZeile = 6 To WSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    With WSh.Cells(iZeile, "N")
      Select Case .Interior.Color
      Case 13395456, 12611584                                      'blau Headerzeile
        sBer = .Address: bCheck = True
      Case 16777215                                                'weiß Leerzeile
        If bCheck = True Then
          WSh.Range(sBer & ":" & .Address).EntireRow.Hidden = True 'Bereich ausblenden
        End If
      Case 52377                                                   'grün = ok
        WSh.Rows(iZeile).Hidden = True
      Case 5287936                                                 'grün Abschluss
        Exit For
      Case Else
        If Not .Value Like "OK" Then bCheck = False                'Zustand merken
      End Select
    
    End With
 
 Next iZeile
    
 WSh.Range("N2").Value = "Anzahl offener Befunde: "
 WSh.Range("I2:O2").Interior.ColorIndex = 6
 WSh.Range("I2:O2").Font.ColorIndex = 3
 WSh.Range("A1").Select
 
 Application.ScreenUpdating = True

End Sub


Sub ErmittleZellfarbe()
 Debug.Print ActiveCell.Interior.Color
End Sub

____________________

viele Grüße aus Freigericht
Karl-Heinz

[sharky51]

Hallo Karl-Heinz,

nochmals vielen Dank, jetzt passt alles und ich kann mir jetzt auch die OK-Einträge usw. in der Spalte "N" ersparen.

Mit diesem Makro blende ich wenn notwendig alles wieder ein:

Code:

'Alle ausgeblendeten Zeilen wieder einblenden
Sub AllesEinblenden()
  With ActiveSheet
      .Columns.Hidden = False            'Kurzform
      .Rows.EntireRow.Hidden = False 'Langform
  End With
 
  Range("N2").Value = "Anzahl aktueller und abgeschlossener Befunde: "
  Range("N2").Select
 
  Range("I2:O2").Interior.ColorIndex = 3
  Range("I2:O2").Font.ColorIndex = 6
  ActiveCell.Characters(Start:=21, Length:=16).Font.ColorIndex = 4
 
End Sub

Den Farbcode im Direkbereich anzuzeigen ist ne gute Idee.
Ich habe mich immer an Farbtabellen orientiert.


Ich wünsche Dir noch ein schönes WE!

[volti]

Vielen Dank Erich für die positive Rückmeldung und auch ich wünsche ein schönes Wochenende aus dem nicht so sonnigen Hessen.

Karl-Heinz

[snb]

Wenn du die leere Zellen in Spalte N keine Validation gibt, reicht dieser Code:

Code:

Sub M_snb()
    For Each it In Columns(14).SpecialCells(-4174).Areas
        it.EntireRow.Hidden = Application.CountIf(it, "OK") = it.Cells.Count - 1
    Next
End Sub

[Klaus-Dieter]

Hallo,

Auswertungen nach Zellformaten sind fast noch schlimmer als Zwischenüberschriften.