Rahmen für dynamische Tabelle

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Mia
Zitat:
genau das war mein Problem... :-) Die Zeilen und Spalten sind nicht jedes mal gleich, d.h sobald eine Spalte bspw. "G" fehlt, geht das ganze nicht mehr auf und alles ist verrutscht.
Excel soll sozusagen selber wissen, wo es den Rahmen in der jeweiligen Farben ziehen soll - je nach Spaltenanzahl und Zeilenanzahl also dynamisch =)
DAS auch die Anzahl der Spalten sich ändern kann, hatte ich aus deinen bisherigen Infos nicht verstanden.
Aber auch genau das ist dann zumindest mein Problem für den Lösungsversuch.
Denn ich, und schon gar nicht Excel, weiß wie die Rahmenformatierung erfolgen soll, wenn z Bsp Spalte C fehlt, oder Spalte J oder Spalte L oder gar mehrere Spalten.
Und....welche Spalten genau fehlen können, weißt nur du.
Vielleicht ist es für uns hilfreich, wenn du eine weitere Bsp-Datei zeigst, die mehrere mögliche Szenarien für vorher enthalten und dann auch entsprechend für nachher.
Versprechen will ich nix, aber vllt fällt mir oder wem anders etwas ein, wenn wir Tabellen und nicht nur Wörter sehen.
Ciao erst mal
Thorsten

Option Explicit Sub suchen() On Error GoTo Fehler Cells.Find(what:="B_C").Activate Columns(ActiveCell.Column).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent3 .TintAndShade = 0 .PatternTintAndShade = 0 End With Exit Sub Fehler: MsgBox "Suchbegriff nicht gefunden" End Sub

...zumindest, was deine neue Bsp-Datei betrifft.
Wenn dein Original nur ein Mü abweicht, dann...dein Problem :-)
Hi Mia
hier erst mal die Datei:
https://www.herber.de/bbs/user/89666.xls
Ich hab mir alle aufgeführten Szenarien von dir angeschaut und dann meinenCode aufgebaut.
Der "rattert" nur erst mal immer die Zeile 2 ab und sucht nach der nächsten leeren Zelle in Zeile 2.
Diese Zelle merkt sich der Code.
Dann werden mit der ersten Farbe alle "Randzellen" gefüllt - rot
Während dessen wird nach der ersten Zelle MIT Text gesucht.
Wenn gefunden, erscheint direkt darüber das Wort "Überschrift".
Mit der zuvor gemerkten Zelle geht die Suche nach der nächsten, relevanten leeren Zelle in Zeile 2 weiter.
Wenn gefunden, wiederholt sich das Färben der Randzellen, jetzt mit Orange und auch der neue Eintrag "Überschrift".
Weiter gehts.
Nächste Treffer werden wieder mit Orange gefüllt.
Und im letzten Durchgang werden nur 3 "Seiten" mit gelb gefüllt.
Teste mal meinen Code mit den Tabellen "Vorher", "vorher_Szenario1" und "vorher_Szenario2".
Bedeutet, erst entsprechende Tabelle anzeigen, dann Code starten.
Mein Code ist so aufgebaut, dass immer die aktuell angezeigte Tabelle vom Code bearbeitet wird.
Merkwürdigkeiten, die mir auffielen:
In deiner Datei, in Tabelle "vorher_Szenario1" folgen nach dem ersten Datenblock DREI leere Spalten.
Ich vermute, da hast du wohl "geschlampt", und es sollen nur ZWEI leere Spalten sein.
Ich hab eine leere Spalte gelöscht.
Du möchtest für die eingefärbten Bereiche Überschriften haben.
Ich finde aber keine Möglichkeit, selbige aus den vorhandenen Daten generieren zu können, weil ich nicht weiß, wie die Überschriften heißen sollen.
Daher musst du überall in den Zeilen im Code, in denen "Überschrift" steht, eben die richtigen Überschriften eintragen.
So, hilfts denn jetzt?
Ciao
Thorsten

Sub mia() Dim rngA As Range, rngB As Range, rngC As Range Application.ScreenUpdating = False Set rngA = Cells(2, 2).CurrentRegion Set rngB = Cells(1, 1).Resize(rngA.Rows.Count + 2, 5) For Each rngC In rngB If Intersect(rngA, rngC) Is Nothing Then rngC.Interior.Color = RGB(255, 0, 0) End If Next Set rngA = Cells(2, 7).CurrentRegion Set rngB = Cells(1, 6).Resize(rngA.Rows.Count + 2, 4) For Each rngC In rngB If Intersect(rngA, rngC) Is Nothing Then rngC.Interior.Color = RGB(228, 109, 10) End If Next Set rngA = Cells(2, 10).CurrentRegion Set rngB = Cells(1, 10).Resize(rngA.Rows.Count + 2, 2) For Each rngC In rngB If Intersect(rngA, rngC) Is Nothing Then rngC.Interior.Color = RGB(228, 109, 10) End If Next Set rngA = Cells(2, 12).CurrentRegion Set rngB = Cells(1, 12).Resize(rngA.Rows.Count + 2, 2) For Each rngC In rngB If Intersect(rngA, rngC) Is Nothing Then rngC.Interior.Color = RGB(255, 255, 0) End If Next Cells(1, 2) = "Überschrift1" Cells(1, 7) = "Überschrift2" Cells(1, 12) = "Überschrift3" End Sub

Beliebteste Forumthreads (12 Monate)

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread