Anzeige
Archiv - Navigation
868to872
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
868to872
868to872
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Werte nach Kriterien kopieren mit mehreren Bedingu

Werte nach Kriterien kopieren mit mehreren Bedingu
14.05.2007 02:33:00
Jan
Hallo liebe Excel/Vba-Freunde,
ich habe folgendes Problem:
Ich habe Datensätze mit ca. 45.000 Werten. In der ersten Spalte steht eine Datum/Zeitangabe und in der zweiten Zahlen zwischen ~-4 und ~+4. Es handelt sich um Einen quasi-harmonischen Schwingungsverlauf. Nun möchte ich die MAXIMA aus der Schwingungskurve mit der zugehörigen Datums/Zeitangabe in ein neues Tabellenblatt kopieren...
Und jetzt zum Problem:
Ich kann die Maxima über eine Do...Loop mit If-Bedingung ja nun relativ simpel in ein anderes Tabellenblatt kopieren, wenn ich nur eine Größer-Als-Bedingung benutze.
ABER: Ich habe ein variierendes Zeitintervall und so kommt es vor, das ein Maximum mit zehn oder mehr Zeitwerten daherkommt.
Das heißt es steht zum Beispiel in zehn Zeilen untereinander der Wert +4 mit unterschiedlichen Zeiten. Jetzt möchte ich den mittleren Wert automatisch mit dem gleichen VBA-Skript kopieren lassen...
Nur hier hören meine VBA-Kenntnisse auf...
Ich weiß, dass ich irgendwie die Anzahl der Werte die größer-gleich sind zählen und dann daraus den mittleren kopieren lassen, aber wie?
Ich bin da echt überfragt...
Hoffentlich könnt ihr mir helfen...
Liebe Grüße aus Bremen,
Jan

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte nach Kriterien kopieren mit mehreren Bed
14.05.2007 07:15:00
Erich
Hallo Jan,
was meinst du mit dem "mittleren Wert"?
Wenn das Maximum in zwei auf einander folgenden Zeilen erreicht wird, soll dann
- der Mittelwert der Zeiten gebildet werden?
- der erste oder der zweite ausgegeben werden?
Geht es um die Zeilen in denen das globale Maximum erreicht wird,
oder sollen auch lokale Maxima ausgegeben werden? (3,5 im Beispiel)
 ABCDEFG
1ZeitWert zu kopieren: oder: 
214.05.2007 05:003     
314.05.2007 06:004     
414.05.2007 07:004 14.05.2007 07:004  
514.05.2007 08:004     
614.05.2007 09:003     
714.05.2007 10:004 welcher dieser beiden?   
814.05.2007 12:004 14.05.2007 12:00414.05.2007 11:404
914.05.2007 13:004     
1014.05.2007 14:003 welcher dieser drei?   
1114.05.2007 15:003,5 14.05.2007 15:00414.05.2007 15:304
1214.05.2007 16:003,5 14.05.2007 16:004  
1314.05.2007 17:003 oder keiner der drei?   

Formeln der Tabelle
ZelleFormel
F8=MITTELWERT(A7:A9)
F11=MITTELWERT(A11:A12)

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: Werte nach Kriterien kopieren mit mehreren Bed
14.05.2007 08:54:00
Jan
Hallo Erich,
erst einmal vielen Dank für die schnelle Antwort.
also den Mittelwert brauche ich nicht...Dafür aber auch jedes lokale Maximum:
Also quasi jeden Wert, der größer-gleich seinem nächsten ist. Und wenn es dann halt mehrere Werte gibt, die diese Bedingung erfüllen, soll der mittlere Wert abgegeben werden. Sprich: In deinem Beispiel von den Werten A7:A9 den Wert A8. Bei einer geraden Anzahl von aufeinanderfolgenden Werten wär es egal, welcher Wert, bei einer ungeraden, den in der Mitte liegenden.
Liebe Grüße,
Jan

AW: Werte nach Kriterien kopieren mit mehreren Bed
14.05.2007 10:48:00
Jan
Hier der bisherige VBA-Code:

Sub Maxima()
Dim iStartZeile As Integer
Dim iZielZeile As Integer
Worksheets("Tabelle1").Select
iStartZeile = 2
Do Until IsEmpty(Cells(iStartZeile, 1))
If Cells(iStartZeile, 2).Value > Cells(iStartZeile + 1, 2) _
And Cells(iStartZeile, 2).Value > Cells(iStartZeile - 1, 2) Then
iZielZeile = iZielZeile + 1
Worksheets("Tabelle2").Rows(iZielZeile).Value = _
Rows(iStartZeile).Value
End If
iStartZeile = iStartZeile + 1
Loop
msgbox ("Maxima gefiltert und kopiert!")
End Sub


Anzeige
AW: lokale Maxima kopieren
14.05.2007 17:14:00
Erich
Hallo Jan,
probier mal das:

Option Explicit
Sub LokaleMaxima()
Dim zQ As Long, lngV As Long, dblM As Double, zZ As Long, dblW As Double
Dim bolAuf As Boolean
With Sheets("Tabelle1")
zQ = 2
lngV = zQ
dblM = .Cells(zQ, 2)
Sheets("Tabelle2").Select: Cells.ClearContents
' oder: Sheets.Add
Rows(1) = .Rows(1).Value
zZ = 1
For zQ = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
dblW = .Cells(zQ, 2)
Select Case dblW
Case Is > dblM
bolAuf = True
dblM = dblW: lngV = zQ
Case Is 

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: lokale Maxima kopieren
16.05.2007 22:06:43
Jan
Hallo Erich,
danke, danke für deine Super-Antwort. War die letzten zwei Tage fern der Zivilisation (beziehungsweise des Internets) und kann dir deswegen jetzt erst antworten. Ich habe ein Screenshot gemacht:
Userbild
Die roten Punkte stellen die gefilterten Werte dar. Ich bin echt begeistert!!
Jetzt aber noch eine Frage:
Kann man mit Select Case, in einer Case bedingung z.B. auch zwei sachen abprüfen lassen, wie größer-gleich Wert oberhalb von Zelle und zusätzlich größer als Wert in Zelle 10 Schritte oberhalb?Oder muss ich dann wieder auf If zurückgreifen?
Auf jeden Fall ein großes Danke-schön und viele Grüße aus Bremen,
Jan

Anzeige
AW: spezielle Zeilen kopieren
16.05.2007 22:44:00
Erich
Hallo Jan,
danke für deine Rückmeldung - freut mich, dass der Code das tut, was du willst.
Wenn du jetzt wirklich so etwas meinst, geht das mit If einfacher als mit Select Case:

Option Explicit
Sub SpezAuswahl()
Dim zQ As Long, zZ As Long
With Sheets("Tabelle1")
Sheets("Tabelle3").Select: Cells.ClearContents
' oder: Sheets.Add
Rows(1) = .Rows(1).Value
zZ = 1
For zQ = 11 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(zQ, 2) >= .Cells(zQ - 1, 2) And _
.Cells(zQ, 2) > .Cells(zQ - 10, 2) Then
zZ = zZ + 1:      Rows(zZ) = .Rows(zQ).Value
End If
Next zQ
Columns.AutoFit
End With
End Sub

Der Sinn bleibt mir hier allerdings verborgen...
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: spezielle Zeilen kopieren
18.05.2007 09:46:00
Jan
Hallo Erich,
also:
Die Select Case-Anweisung erfüllte bei 7 meiner 8 vorhandenen Datenreihen genau das, was ich mir gewünscht habe. Bei der achten Datenreihe ergab sich folgendes Problem:
Userbild
Hier sind die roten Punkte die gefunden Maxima...Diese Kurve ist also relativ "scharfkantig" und es sind einige kleine Maxima auf den an- und absteigenden Ästen vorhanden, die ich nicht haben möchte. Deswegen dachte ich mir, wenn man zusätzlich in deinem Super-Makro einbauen könnte, das es überprüft, ob die Werte die er speichern soll auch noch die Bedingung (Wert größer als der Wert 10 Zeilen vorher und nachher) erfüllen, könnte man nur die "wirklichen" Maxima filtern.
Ganz, ganz viele Grüße und ein dickes Danke-Schön,
Jan

Anzeige
AW: spezielle Zeilen kopieren
24.05.2007 11:18:00
Jan
Hallo Erich,
bin nach tagelangem Grübeln auf eine vorerst zufriednstellende Lösung gekommen und habe dazu eine If-Schleife benutzt. Danke nochmals für deinen Ansatz, der hat mich echt weiter gebracht. Hier nochmal der Code. Würde mich freuen, wenn du mir dazu eine Rückmeldung geben würdest.
Viele Grüße,
Jan
Option Explicit

Sub LokaleTest()
Dim iQuellZelle As Long, lngV As Long, dblM As Double, iZielzelle As Long, dblW As Double
Dim bolAuf As Boolean, lower As Long, upper As Long, dblower As Double, dbupper As Double
With Sheets("Tabelle1")
iQuellZelle = 10
lngV = iQuellZelle
dblM = .Cells(iQuellZelle, 2)
Sheets("Tabelle3").Select: Cells.ClearContents
Rows(1) = .Rows(1).Value
iZielzelle = 1
For iQuellZelle = 11 To .Cells(Rows.Count, 1).End(xlUp).Row
lower = iQuellZelle - 10
upper = iQuellZelle + 10
dblW = .Cells(iQuellZelle, 2)
dblower = .Cells(lower, 2)
dbupper = .Cells(upper, 2)
If dblW > dblM And dblW > dblower And dblW > dbupper Then
bolAuf = True
dblM = dblW: lngV = iQuellZelle
ElseIf dblW 


Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige