Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1116to1120
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
Inhaltsverzeichnis

Bitte um Hilfe bei einer Programmieraufgabe

Bitte um Hilfe bei einer Programmieraufgabe
Ilka
Hallo,
ich mache die ersten Schritte in VBA und komme bei der folgenden Aufgabe nicht weiter:
Wie ermittelt man mit VBA den 2. höchsten Preis ohne die Funktion kgrösste oder andere Funktionen zu verwenden. Die Preise sind in den Zellen A2:A59 gespeichert.
Es geht mir hierbei darum, Programmiertechniken zu erlernen.
Über Lösungsansätze oder gar fertige Lösungen würde ich mich sehr freuen.
Gruß
Ilka Maria
AW: Bitte um Hilfe bei einer Programmieraufgabe
22.11.2009 17:55:33
Josef
Hallo Ilka,
da gibt's sicher viele Möglichkeiten.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub derZweite()
  Dim varValue() As Variant
  Dim lngIndex As Long
  Dim dblResult As Double
  
  varValue = Application.Transpose(Range("A2:A59"))
  
  QuickSort varValue
  
  dblResult = varValue(1)
  
  For lngIndex = 2 To UBound(varValue)
    If varValue(lngIndex) > dblResult Then
      dblResult = varValue(lngIndex)
      Exit For
    End If
  Next
  
  MsgBox CStr(dblResult)
  
End Sub

Sub QuickSort(data() As Variant, Optional UG, Optional OG)
  Dim P1&, P2&, T1 As Variant, T2 As Variant
  
  UG = IIf(IsMissing(UG), LBound(data), UG)
  OG = IIf(IsMissing(OG), UBound(data), OG)
  
  P1 = UG
  P2 = OG
  T1 = data((P1 + P2) / 2)
  
  Do
    
    Do While (data(P1) < T1)
      P1 = P1 + 1
    Loop
    
    Do While (data(P2) > T1)
      P2 = P2 - 1
    Loop
    
    If P1 <= P2 Then
      T2 = data(P1)
      data(P1) = data(P2)
      data(P2) = T2
      P1 = P1 + 1
      P2 = P2 - 1
    End If
    
  Loop Until (P1 > P2)
  
  If UG < P2 Then QuickSort data, UG, P2
  If P1 < OG Then QuickSort data, P1, OG
  
End Sub

Gruß Sepp

Anzeige
Korrektur
22.11.2009 18:03:15
Josef
Hallo Ilka,
du wolltest ja den zweithöchsten Preis.
Sub derZweithopechste()
  Dim varValue() As Variant
  Dim lngIndex As Long
  Dim dblResult As Double
  
  varValue = Application.Transpose(Range("A2:A59"))
  
  QuickSort varValue
  
  dblResult = varValue(UBound(varValue))
  
  For lngIndex = UBound(varValue) - 1 To 1 Step -1
    If varValue(lngIndex) < dblResult Then
      dblResult = varValue(lngIndex)
      Exit For
    End If
  Next
  
  MsgBox CStr(dblResult)
  
End Sub

Gruß Sepp

Anzeige
AW: Bitte um Hilfe bei einer Programmieraufgabe
22.11.2009 18:25:21
Ilka
Hallo Sepp,
oh, ging das aber schnell. Danke
Der erste Test verlief leider nicht erfolgreich. Ich glaube es liegt am Sortierverfahren.
Leider ist es mir nicht möglich, nach der Zeile
varValue = Application.Transpose(Range("A2:A59"))
die Daten in Spalte B anzeigen zu lassen.
For i = 2 to 59
cells(I,2) = varValue(i) funktioniert nicht.
Aber dafür gibt es bestimmt eine Lösung.
Die Hilfe hat den Befehl Transpose nicht gezeigt.
Hängt u.U. mit meiner Version zusammen (Excel 2000)
Du siehst, aller Anfang ist schwer ...
Vielleicht hast Du Lust, nochmals zu antworten.
Gruß
Ilka Maria
Anzeige
xl9 kennt WshFct.Transpose! Gruß owT
22.11.2009 22:18:27
Luc:-?
:-?
AW: Bitte um Hilfe bei einer Programmieraufgabe
22.11.2009 17:57:44
Daniel
Hi
du solltest mal genauer definieren, was erlaubt ist und was nicht.
einfachster Weg mit VBA wäre, die Daten absteigend zu sortieren und dann den Wert aus A3 zu nehmen.
ansonsten müsstest du so vorgehen:
1. in einer Schleife die Werte durchgehen und den grössten Wert ermitteln:
2. in einer 2. Schleife nochmal durch die Werte gehen und prüfen, welches der Grösste Wert ist, der nicht dem MaxWert entspricht:
for Ze = 2 to 59
if Cells(ze, 1).Value > MaxWert then MaxWert = Cells(Ze,1).Value
next
For Ze = 2 to 59
if Cells(ze,i).Value > ZweitMax And Cells(ze,1).Value  MaxWert then ZweitMax = Cells(ze,i). _
Value
next
Gruß, Daniel
Anzeige
AW: Danke
22.11.2009 18:27:57
Ilka
Hallo Andre,
vielen Dank für Deinen Beitrag.
Ich wollte ohne Kgrösste auskommen. Dieser Ansatz war mir bekannt.
Einen schönen Abend.
Gruß
Ilka Maria
AW: Bitte um Hilfe bei einer Programmieraufgabe
22.11.2009 18:03:09
Daniel
Hi
du solltest mal genauer definieren, was erlaubt ist und was nicht.
einfachster Weg mit VBA wäre, die Daten absteigend zu sortieren und dann den Wert aus A3 zu nehmen.
ansonsten müsstest du so vorgehen:
1. in einer Schleife die Werte durchgehen und den grössten Wert ermitteln:
2. in einer 2. Schleife nochmal durch die Werte gehen und prüfen, welches der Grösste Wert ist, der nicht dem MaxWert entspricht:
for Ze = 2 to 59
if Cells(ze, 1).Value > MaxWert then MaxWert = Cells(Ze,1).Value
next
For Ze = 2 to 59
if Cells(ze,1).Value > ZweitMax And Cells(ze,1).Value  MaxWert then ZweitMax = Cells(ze,1). _
Value
next
Gruß, Daniel
Anzeige
AW: Danke schön
22.11.2009 18:55:18
Ilka
Hallo Daniel,
ja, so sollte es sein, ohne zu sortieren.
Ich danke Dir für Deine Programmzeilen, um die ich morgen weitere Zeilen legen werde.
Gruß
Ilka Maria
kommt noch einer hinterher...
22.11.2009 18:15:06
Erich
Hi,
oder so (zwei Varianten - entweder kann der 2. Preis auch mal
so groß sein wie der 1. oder eben nicht):

Option Explicit
Sub ZweitGr()
Dim arrW As Variant, lngZ As Long, dblM As Double, dblZ As Double
arrW = Application.Transpose( _
Cells(2, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1))
For lngZ = 1 To UBound(arrW)
If dblM 
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
kommt noch einer hinterher...?
22.11.2009 18:27:28
robert
Hi Erich,
hast du das getestet ?
Tabelle1
 ABCDE
15       
2888       
3666       
4555       
5889       
6133       
788  Ergebnis:1.999
855    2.777
9777       
10999       
1113       
1212       
1312       

Tabellendarstellung in Foren Version 4.28


gruß robert
Anzeige
Korrektur
22.11.2009 18:39:36
Erich
Hi Robert,
nein, nicht genug getestet - dafür einen Gedankenfehler untergebracht *rotwerd*
Dank Dir fürs Testen und den Hinweis!
Vielleicht besser:

Sub ZweitGr()
Dim arrW As Variant, lngZ As Long, dblM As Double, dblZ As Double
arrW = Application.Transpose( _
Cells(2, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1))
For lngZ = 1 To UBound(arrW)
If dblM 
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
..Ja, jetzt passt es :-) owT
22.11.2009 18:48:12
robert
AW: Korrektur
22.11.2009 19:00:48
Ilka
Hallo Erich,
vielen Dank für Dein Programm.
Das Lesen und Verstehen macht mir noch zu schaffen.
Vielleicht hilf ein Test im Einzelschrittmodus.
Gruß
Ilka Maria
Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige