Office: Wenn - Eintrag vorhanden - darüber Querstich einfügen

Hallo Excel Freaks!

Ich habe folgendes Problem. Ich muss gerade eine Excel Tabelle bearbeiten, die die gesamten Mitarbeiter des Konzernsbeinhaltet --> mehrere tausend Einträge

Ich soll jetzt jene Abteilungen herausfinden, die nur aus einem Mitarbeiter bestehen.

Dazu hätte ich mir folgendes überlegt: Da jede Abteilung in der Liste immer mit dem Abteilungsleiter beginnt, soll Excel immer dann wenn in der Zelle von Spalte C ein Eintrag vorhanden ist, in der Zeile darüber einene Querstrich machen...

Der derzeite Stand ist im beiligenden Excel File im Sheet 1 so wie es derzeit ist und im Sheet 2, so wie es sein sollte...

Hoffe, dass es dafür im VBA irgendeine Lösung gibt.

Damit könnte man das Problem schonmal gut veranschaulichen.
In einem zweiten Schritt, wäre es noch cool jene Abteilungen rauszufiltern, die nur aus einem Mitarbeiter bestehen. Im Beispiel die Abteilung E. Allerdings gibts auch Abteilungen die keinen Leiter haben, also nur einen Eintrag in Spalte D, aber keinen Eintrag in Spalte C.

Danke vielmals im Voraus.

LG strikerman

 

Hi,

Code:

Sub Querstrich()
   Dim rngZelle As Range
   For Each rngZelle In Range("C3:C" & IIf(IsEmpty(Cells(Rows.Count, 1)), _
      Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).SpecialCells(xlCellTypeConstants)
      With Range(Cells(rngZelle.Row - 1, 1), Cells(rngZelle.Row - 1, 4)).Borders(xlEdgeBottom)
          .LineStyle = xlContinuous
          .ColorIndex = 0
          .TintAndShade = 0
          .Weight = xlMedium
      End With
      If Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row + 1, 4) And Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row - 1, 4) _
         Then Range(Cells(rngZelle.Row, 1), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 6
   Next rngZelle
End Sub

Die Abteilungen mit nur 1 Eintrag in Spalte C werden mit Hintergrundfarbe Gelb markiert

Bis später,
Karin

 

Hallo Karin,

habe deine Formel bereits eingefügt und gespeichert, allerdings tut sich nichts. Muss ich noch irgendwas anderes drücken, damit das Makroa ausgeführt wird?

LG strikerman

 

Hi,

du musst den Code in ein allgemeines Modul einfügen und dann über Extras -> Makros starten.

Bis später,
Karin

 

Hi,

Leider funktioniert es nicht. Es kommt die Fehlermeldung: Objekt unterstützt diese Eigenschaft oder Methode nicht

LG

 

Hi,

es ist immer günstig, genau zu beschreiben, wo ein Fehler im Code auftritt, dann ist wesentlich es einfacher, eine Lösung bzw. die Ursache zu finden - bei mir tritt dieser Fehler nämlich nicht auf, aber ich verwende. Excel2010.

Lösche die Zeile .TintAndShade = 0 - diese Funktion gibt es erst ab Excel2007.

Bis später,
Karin

 

Hi Karin,

Danke für den Hinweis. Funktioniert nun perfekt!!

Ich hätte noch eine Frage/Bitte. Könntest du die Formel so adaptieren, dass immer beim ersten neuen Eintrag (neue Abteilung) in Spalte D eine Linie eingefügt wird (entweder for dem erste neuen Eintrag oder nach dem letzten)? Bin nämlich nun gerade draufgekommen, dass doch nicht alle Abteilungsleiter am Beginn ihrer Abteilung aufgelistet sind...

Vielen Dank!

LG Michael

 

Hi Michael,

das ist keine Formel sondern VBA-Code :)

Code:

Sub Querstrich()
   Dim rngZelle As Range
   For Each rngZelle In Range("D3:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), _
      Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).SpecialCells(xlCellTypeConstants)
      If Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row + 1, 4) Then
         With Range(Cells(rngZelle.Row, 1), Cells(rngZelle.Row, 4)).Borders(xlEdgeBottom)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .Weight = xlMedium
         End With
         If Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row + 1, 4) And Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row - 1, 4) _
            Then Range(Cells(rngZelle.Row, 1), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 6
      End If
   Next rngZelle
End Sub

Bis später,
Karin

 

Hi Karin,

Danke für deinen Vorschlag. In meinem vereinfachten hochgeladenen Beispiel funktioniert es perfekt. Allerdings hab ich in meinem eigentlich Beispiel an dem ich arbeite um einiges mehr Spalten stehen, als in dem hochgeladenen Beispielen.

Hier das gesamte File. Vielleicht könntest du das Makro auf dieses nun anpassen. Leider kann ich das File nicht hochladen, da es selbst ohne die ganzen Daten zu groß ist. Von der Struktur schaut es genau gleich aus, allerdings befindet sich das Board Level des Abteilungsleiters in Spalte N, der Sheet hat läuft von Spalte A bis Spalte CD und bis inklusive Zeile 2965.

Leider kann ich nicht garantieren, ob neue Spalten und/oder Zeilen hinzugefügt werden. Könntest du mir deshalb kurz erklären, wie man dann diese Paramter im VBA bei einer Erweiterung anpassen müsste?

Vielen, vielen Dank für die Hilfe!

LG Michael

 

Hi Michael,

der Ausdruck

Code:

Cells(rngZelle.Row, 4)

bezieht sich auf eine Zelladresse, wobei rngZelle.Row die fortlaufende Zeilnnummer ist und die "4" die Spaltennummer - das musst du entsprechend an deine geänderten Spalten-Bedingungen anpassen. Schau auch einfach mal in die VBA-Hilfe zum Stichwort Range.Cells-Eigenschaft

Ich habe den Code noch mal mit einigen Kommentaren versehen, so kannst du besser nachvollziehen was vor sich geht und es wird dir leichter fallen, ihn an deine Bedingungen anzupassen.

Code:

Sub Querstrich()
   Dim rngZelle As Range
   ' Schleife über jede Zelle in Spalte D (ab Zeile 3 bis zur letzten belegten Zeile) welche einen Eintrag enthält.
   ' Da jede Zelle bis zur letzten Zeile gefüllt ist wird somit jede Zelle durchlaufen
   For Each rngZelle In Range("D3:D" & IIf(IsEmpty(Cells(Rows.Count, 1)), _
      Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)).SpecialCells(xlCellTypeConstants)
      ' der Inhalt der laufenden Zeile in Spalte D ist verschieden vom Inhalt der nächstfolgenden Zeile,
      ' folglich beginnt eine neue Abteilung und es soll ausgeführ werden was in der If-Anweisung steht
      If Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row + 1, 4) Then
         ' Zellbereich von Spalte A bis D der laufenden Zeile wird mit einem Rahmen unten versehen
         With Range(Cells(rngZelle.Row, 1), Cells(rngZelle.Row, 4)).Borders(xlEdgeBottom)
             .LineStyle = xlContinuous
             .ColorIndex = 0
             .Weight = xlMedium
         End With
         ' der Inhalt der laufenden Zeile in Spalte D ist verschieden vom Inhalt der nächstfolgenden Zeile und
         ' vom Inhalt der vorangehenden Zeile, folglich hat die Abteilung nur 1 Eintrag und der Bereich von Spalte A
         ' bis Spalte D wird mit Hintergrundfarbe Gelb formatiert
         If Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row + 1, 4) And Cells(rngZelle.Row, 4) <> Cells(rngZelle.Row - 1, 4) _
            Then Range(Cells(rngZelle.Row, 1), Cells(rngZelle.Row, 4)).Interior.ColorIndex = 6
      End If
   Next rngZelle
End Sub

Bis später,
Karin

 

Hallo Karin!

Danke ich hab es bereits auf meine Bedürfnisse angepasst und es funktioniert perfekt. Hast mir sehr geholfen. Danke!

LG Michael