Hallo Sabine,
dass du mehrere Tabellenblätter auswerten willst, hatte ich nicht verstanden, Ich habe dich jetzt wie folgt verstanden:
Es gibt eine Arbeitsmappe mit mehreren Tabellenblätter. In jeder Tabelle befinden sich ab Zeile 8 in Spalte A Zeitangaben und in fortlaufenden Spalten ab Spalte B Werte, die zu diesen Zeitangaben gehören.
In Zeile 7 befinden sich ab Spalte B jeweils Tabellenköpfe für die einzelnen Spalten.
Die Werte können positiv und negativ sein. Spaltenweise soll jeweils der Wert vor dem Vorzeichenwechsel fett formatiert werden, es sein, dass es einen Wert 0 gibt, dann ist dieser fett zu formatieren. Relative Maxima der Werte sollen rot, relative Minima blau hervorgehoben werden.
Zu jedem Tabellenblatt soll ein neues Tabellenblatt erzeugt werden, das den Namen des Urprungstabellenblatts mit vorangestelltem "AW_" erhalten soll. In die neuen Tabellenblatt sollen in die Zeile 2 die Tabellenköpfe so übernommen werden, dass der aus Spalte B nach Spalte B übertragen wird, die weiteren aber jeweils mit einer Spalte Zwischenraum zum vorhergehenden. Unter die Tabellenköpfe in den neuen Tabellenblättern sollen die jeweiligen Werte der Nullstellen, Minima und Maxima in der Formatierung der Urprungstabellenblätter aufgelistet werden. In der Zelle links neben dem Wert soll die zugehörige Zeitausgabe aus Spalte 1 der Urprungstabellenblätter gesetzt werden.
Sub max_min()
Zeile1 = 8
Spalte1 = 2
farbemax = 3
farbemin = 5
For Each WS In Worksheets
If Left(WS.Name, 3) = "AW_" Then WS.Delete
Next
For Each WS In Worksheets
If Left(WS.Name, 3) keinergrößer "AW_" Then
Sheets.Add
ActiveSheet.Name = "AW_" + WS.Name
Set WN = ActiveSheet
WS.Activate
Cells.Interior.ColorIndex = xlNone
For j = Spalte1 To Cells(8, Columns.Count).End(xlToLeft).Column
nz = 3
WN.Cells(nz - 1, 2 * j - 2) = Cells(Zeile1 - 1, j) 'Tabellenköpfe?
s = Sgn(Cells(Zeile1 + 1, j) - Cells(Zeile1, j))
If s = 0 Then
For i = Zeile1 To Cells(Rows.Count, j).End(xlUp).Row - 1
t = Sgn(Cells(i + 1, j) - Cells(i, j))
If t keinergrößer 0 Then Exit For
Next i
If i keiner Cells(Rows.Count, j).End(xlUp).Row - 1 Then
If t = -1 Then
Cells(Zeile1, j).Interior.ColorIndex = farbemax
WN.Cells(nz, 2 * j - 2) = Cells(Zeile1, j)
WN.Cells(nz, 2 * j - 3) = Cells(Zeile1, 1)
WN.Cells(nz, 2 * j - 2).Interior.ColorIndex = farbemax
nz = nz + 1
Else
Cells(Zeile1, j).Interior.ColorIndex = farbemin
WN.Cells(nz, 2 * j - 2) = Cells(Zeile1, j)
WN.Cells(nz, 2 * j - 3) = Cells(Zeile1, 1)
WN.Cells(nz, 2 * j - 2).Interior.ColorIndex = farbemin
nz = nz + 1
End If
End If
End If
For i = Zeile1 To Cells(Rows.Count, j).End(xlUp).Row - 1
If (Sgn(Cells(i + 1, j)) keinergrößer Sgn(Cells(i, j))) Or Cells(i, j) = 0 Then 'Nullstellen
Cells(i, j).Font.Bold = True
WN.Cells(nz, 2 * j - 2) = Cells(i, j)
WN.Cells(nz, 2 * j - 3) = Cells(i, 1)
WN.Cells(nz, 2 * j - 2).Font.Bold = True
nz = nz + 1
End If
Select Case Cells(i + 1, j) - Cells(i, j)
Case Is keiner 0
If s keinergrößer -1 Then
s = -1
Cells(i, j).Interior.ColorIndex = farbemax
WN.Cells(nz, 2 * j - 2) = Cells(i, j)
WN.Cells(nz, 2 * j - 3) = Cells(i, 1)
WN.Cells(nz, 2 * j - 2).Interior.ColorIndex = farbemax
nz = nz + 1
End If
Case Is größer 0
If s keinergrößer 1 Then
s = 1
Cells(i, j).Interior.ColorIndex = farbemin
WN.Cells(nz, 2 * j - 2) = Cells(i, j)
WN.Cells(nz, 2 * j - 3) = Cells(i, 1)
WN.Cells(nz, 2 * j - 2).Interior.ColorIndex = farbemin
nz = nz + 1
End If
Case Else
If i größer Zeile1 Then
Cells(i, j).Interior.ColorIndex = Cells(i - 1, j).Interior.ColorIndex
WN.Cells(nz, 2 * j - 2) = Cells(i, j)
WN.Cells(nz, 2 * j - 3) = Cells(i, 1)
WN.Cells(nz, 2 * j - 2).Interior.ColorIndex = farbemax
nz = nz + 1
End If
End Select
Next i
Next j
End If
Next
End Sub
Gruß
Holger
Sabine schrieb am 27.06.2009 17:18:58:
Hallo Holger,
vielen Dank, dass Du mir wieder hilfst.
Mein Hauptproblem ist das Erzeugen und Beschreiben der neuen Tabellenblätter. In der Ersten For-Next-Schleife schaust Du nach ob schon neue Tabellenblätter existieren und löschst diese, das habe ich verstanden. Müsste danach nicht wieder eine Schleife kommen, die zu jedem Tabellenblatt ein neues hinzufügt?
Mit:
Sheets.Add
ActiveSheet.Name = "AW_" + TabName
Sheets(TabName).Activate
wird doch nur eine Tabelle vor dem ersten Tabellenblatt erzeugt. Ich möchte aber für jedes existierende Tabellenblatt eine neue (Auswert-)Tabelle erzeugen, diese dahinter anordnen und mit den dazugehörigen Max-Min-Werten und den Nullstellen füllen.
Die Tabellenköpfe sollen mit in die neue Tabelle übernommen werden und in der zweiten Zeile stehen.
Die Zelladressierung ist so gemeint, dass die Spalten in der Ursprungstabellen fortlaufend belegt sind und von Spalte 2 an untersucht werden sollen. In der neuen Tabelle wird zunächst dazwischen immer eine Spalte frei gelassen, da in diese dann aus der ersten Spalte (der Ursprungstabelle) der Zeitpunkt des Auftretens eines Maximums, Minimums bzw. einer Nullstelle übernommen werden soll (und zwar für jede Spalte extra).
Ich hoffe ich falle Dir mit meinen „Sorgen“ nicht allzu sehr zur Last und würde mich freuen, wieder von Dir zu hören.
Liebe Grüße
Sabine
Holger schrieb am 27.06.2009 11:41:14:
Hallo Sabine,
ich würde die neue Tabelle sofort bei der Min-Max-Nullstellen-Prüfung erzeugen. Ob ich die Adressen auf der neuen Tabelle richtig verstanden habe, weiß ich nicht. Ich lasse die Daten bei A3 unabhängig von deiner Bemerkung zu den Tabellenköpfen beginnen und übernehme die Formatierung. Du kannst es aber leicht ändern.
Sub max_min()
Zeile1 = 8
Spalte1 = 2
farbemax = 3
farbemin = 5
TabName = ActiveSheet.Name
For Each WS In Worksheets
If WS.Name = "AW_" + TabName Then WS.Delete
Next
Sheets.Add
ActiveSheet.Name = "AW_" + TabName
Sheets(TabName).Activate
nz = 3
Cells.Interior.ColorIndex = xlNone
For j = Spalte1 To Cells(8, Columns.Count).End(xlToLeft).Column
nz = 3
s = Sgn(Cells(Zeile1 + 1, j) - Cells(Zeile1, j))
If s = 0 Then
For i = Zeile1 To Cells(Rows.Count, j).End(xlUp).Row - 1
t = Sgn(Cells(i + 1, j) - Cells(i, j))
If t kleinergrößer 0 Then Exit For
Next i
If i kleiner Cells(Rows.Count, j).End(xlUp).Row - 1 Then
If t = -1 Then
Cells(Zeile1, j).Interior.ColorIndex = farbemax
Sheets("AW_" + TabName).Cells(nz, j - 1) = Cells(Zeile1, j)
Sheets("AW_" + TabName).Cells(nz, j - 1).Interior.ColorIndex = farbemax
nz = nz + 1
Else
Cells(Zeile1, j).Interior.ColorIndex = farbemin
Sheets("AW_" + TabName).Cells(nz, j - 1) = Cells(Zeile1, j)
Sheets("AW_" + TabName).Cells(nz, j - 1).Interior.ColorIndex = farbemin
nz = nz + 1
End If
End If
End If
For i = Zeile1 To Cells(Rows.Count, j).End(xlUp).Row - 1
If (Sgn(Cells(i + 1, j)) kleinergrößer Sgn(Cells(i, j))) Or Cells(i, j) = 0 Then 'Nullstellen
Cells(i, j).Font.Bold = True
Sheets("AW_" + TabName).Cells(nz, j - 1) = Cells(i, j)
Sheets("AW_" + TabName).Cells(nz, j - 1).Font.Bold = True
nz = nz + 1
End If
Select Case Cells(i + 1, j) - Cells(i, j)
Case Is kleiner 0
If s kleinergrößer -1 Then
s = -1
Cells(i, j).Interior.ColorIndex = farbemax
Sheets("AW_" + TabName).Cells(nz, j - 1) = Cells(i, j)
Sheets("AW_" + TabName).Cells(nz, j - 1).Interior.ColorIndex = farbemax
nz = nz + 1
End If
Case Is größer 0
If s kleinergrößer 1 Then
s = 1
Cells(i, j).Interior.ColorIndex = farbemin
Sheets("AW_" + TabName).Cells(nz, j - 1) = Cells(i, j)
Sheets("AW_" + TabName).Cells(nz, j - 1).Interior.ColorIndex = farbemin
nz = nz + 1
End If
Case Else
If i größer Zeile1 Then
Cells(i, j).Interior.ColorIndex = Cells(i - 1, j).Interior.ColorIndex
Sheets("AW_" + TabName).Cells(nz, j - 1) = Cells(i, j)
Sheets("AW_" + TabName).Cells(nz, j - 1).Interior.ColorIndex = farbemax
nz = nz + 1
End If
End Select
Next i
Next j
End Sub
Gruß
Holger
Sabine schrieb am 26.06.2009 18:35:52:
Hallo,
auf meine letzte Anfrage(Beitrag: Nullstellen, Maxima und Minima markieren), wurde mir von Holger wunderbar geholfen. Nun möchte ich die so erzeugten Tabellen weiterbearbeiten. Meine Testversion funktioniert, ist aber wahrscheinlich etwas umständlich und auch nicht vollständig:
Sub Formatierte_Werte_übertragen()
Zeile1 = 8
Spalte1 = 2
Zeile2 = 3
Spalte2 = 8
farbemax = 3 'rot
farbemin = 33 'hellblau
For j = Spalte1 To Cells(Zeile1,Columns.Count).End(xlToLeft).Column
For i = Zeile1 To Cells(Rows.Count, Spalte1).End(xlUp).Row
If Cells(i, Spalte1).Font.Bold = True Then
Cells(Zeile2, Spalte2) = Cells(i, Spalte1)
Cells(Zeile2, Spalte2).Font.Bold = True
Cells(Zeile2, Spalte2 - 1) = Cells(i, 1)
Zeile2 = Zeile2 + 1
ElseIf Cells(i, Spalte1).Font.ColorIndex = farbemax Then
Cells(Zeile2, Spalte2) = Cells(i, Spalte1)
Cells(Zeile2, Spalte2).Font.ColorIndex = farbemax
Cells(Zeile2, Spalte2 - 1) = Cells(i, 1)
Zeile2 = Zeile2 + 1
ElseIf Cells(i, Spalte1).Font.ColorIndex = farbemin Then
Cells(Zeile2, Spalte2) = Cells(i, Spalte1)
Cells(Zeile2, Spalte2).Font.ColorIndex = farbemin
Cells(Zeile2, Spalte2 - 1) = Cells(i, 1)
Zeile2 = Zeile2 + 1
End If
Next i
Spalte1 = Spalte1 + 1
Zeile2 = 3
Spalte2 = Spalte2 + 2
Next j
End Sub
Nun möchte ich die so herausgefilterten Daten nicht, wie hier geschehen, in eine der hinteren Spalten schreiben, sondern in ein neues Tabellenblatt, das hinter das Tabellenblatt mit den Daten angehängt wird. Das neue Tabellenblatt soll mit „AW & `dem Namen der Ursprungstabelle‘“ benannt sein. Es soll darin mit Spalte A und Zeile 3 begonnen werden. In Zeile 2 werden die Tabellenköpfe übernommen allerdings immer in die übernächste Spalte, da jeder Datenspalte der Zeitpunkt aus Spalte A vorgesetzt wird.
Es gibt eine variierende Anzahl von Daten-Tabellenblättern je Arbeitsmappe mit 7 bis 8 Spalten und unbegrenzt viele Zeilen je Tabellenblatt. Die Formatierung soll beibehalten werden.
Vielleicht kann mir jemand helfen.
Vielen Dank
Sabine
|