HERBERS Excel-Forum - das Archiv
Bewerten Sie hier bitte das Excel-Portal
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
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

Korrektur
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

AW: Bitte um Hilfe bei einer Programmieraufgabe
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
xl9 kennt WshFct.Transpose! Gruß owT
Luc:-?

:-?
AW: Bitte um Hilfe bei einer Programmieraufgabe
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
AW: Bitte um Hilfe bei einer Programmieraufgabe
Andre

Hallo,
schau mal hier:
http://www.office-loesung.de/ftopic88738_0_0_asc.php
MFG Andre
AW: Danke
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
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
AW: Danke schön
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...
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 < arrW(lngZ) Then
dblM = arrW(lngZ)
Else
'                            für 2. <  1.
If dblZ < arrW(lngZ) And arrW(lngZ) < dblM Then dblZ = arrW(lngZ)
'                            für 2. <= 1.
'        If dblZ < arrW(lngZ) And arrW(lngZ) <= dblM Then dblZ = arrW(lngZ)
End If
Next lngZ
MsgBox "1.: " & dblM & vbLf & "2.: " & dblZ
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
kommt noch einer hinterher...?
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
Korrektur
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 < arrW(lngZ) Then
dblZ = dblM
dblM = arrW(lngZ)
Else
'                            für 2. <  1.
If dblZ < arrW(lngZ) And arrW(lngZ) < dblM Then dblZ = arrW(lngZ)
'                            für 2. <= 1.
'        If dblZ < arrW(lngZ) And arrW(lngZ) <= dblM Then dblZ = arrW(lngZ)
End If
Next lngZ
MsgBox "1.: " & dblM & vbLf & "2.: " & dblZ
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
..Ja, jetzt passt es :-) owT
robert

AW: Korrektur
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