Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Bitte um Hilfe bei einer Programmieraufgabe | Herbers Excel-Forum


Betrifft: Bitte um Hilfe bei einer Programmieraufgabe von: Ilka Maria
Geschrieben am: 22.11.2009 17:41:42

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

  

Betrifft: AW: Bitte um Hilfe bei einer Programmieraufgabe von: Josef Ehrensberger
Geschrieben am: 22.11.2009 17:55:33

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



  

Betrifft: Korrektur von: Josef Ehrensberger
Geschrieben am: 22.11.2009 18:03:15

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



  

Betrifft: AW: Bitte um Hilfe bei einer Programmieraufgabe von: Ilka Maria
Geschrieben am: 22.11.2009 18:25:21

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


  

Betrifft: xl9 kennt WshFct.Transpose! Gruß owT von: Luc:-?
Geschrieben am: 22.11.2009 22:18:27

:-?


  

Betrifft: AW: Bitte um Hilfe bei einer Programmieraufgabe von: Daniel
Geschrieben am: 22.11.2009 17:57:44

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


  

Betrifft: AW: Bitte um Hilfe bei einer Programmieraufgabe von: Andre ´
Geschrieben am: 22.11.2009 17:59:36

Hallo,

schau mal hier:

http://www.office-loesung.de/ftopic88738_0_0_asc.php

MFG Andre


  

Betrifft: AW: Danke von: Ilka Maria
Geschrieben am: 22.11.2009 18:27:57

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


  

Betrifft: AW: Bitte um Hilfe bei einer Programmieraufgabe von: Daniel
Geschrieben am: 22.11.2009 18:03:09

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


  

Betrifft: AW: Danke schön von: Ilka Maria
Geschrieben am: 22.11.2009 18:55:18

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


  

Betrifft: kommt noch einer hinterher... von: Erich G.
Geschrieben am: 22.11.2009 18:15:06

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


  

Betrifft: kommt noch einer hinterher...? von: robert
Geschrieben am: 22.11.2009 18:27:28

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


  

Betrifft: Korrektur von: Erich G.
Geschrieben am: 22.11.2009 18:39:36

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


  

Betrifft: ..Ja, jetzt passt es :-) owT von: robert
Geschrieben am: 22.11.2009 18:48:12




  

Betrifft: AW: Korrektur von: Ilka Maria
Geschrieben am: 22.11.2009 19:00:48

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