schleife mit mehreren Abfragen
19.07.2007 12:23:32
Hubertus
ich habe hier ein für mich recht anspruchsvolles Problem.
In einer Tabelle soll in der ersten Spalte nach einem gegebenen Durchmesser (d) gesucht werden. dieser kann auch mehrfach vorkommen. Wenn die erste Übereinstimmung vorliegt, soll in der entsprechenden Zeile ein Wert Y kopiert werden.
Mit diesem wird folgendermaßen gerechnet:
1.) P = Fr + Fa * Y --> (Fr, Fa gegeben)
2.) Co = P * (fl / fa) --> (fl, fa gegeben)
dann soll der berechnete Wert Co mit dem Wert Co aus der gewählten Zeile verglichen werden. ist der berechnete Wert GRÖSSER, soll die gleiche Rechnung in der nächsten Zeile mit demselben Durchmesser d wiederholt werden.
Sobald aber CoRechnung > CoTabelle ist, soll aus der Spalte "Bezeichnung" die Bauteilbezeichnung ausgegeben werden.
Das ganze soll als Excel-VBA Makro hinterlegt sein und bei geöffneter Mappe (aber nicht geöffnetem Blatt) automatisch aktuell gehalten werden. Sprich sobald sich d,Fa oder Fr ändert, sollen die Berechnungen neu laufen. wenn das nicht möglich ist, soll auf einem Anderen Blatt per "Aktualisieren- Schaltfläche" die Berechnung aufgerufen werden.
So, hoffe das war verständlich :-)
Ganz untätig war ich auch net - mier meine ersten Versuche:
Function Lagerwahl()
Application.Volatile
Dim d As Long
Dim Z As Long
Dim x As Integer
Dim y As Integer
Dim Fr As Long
Dim Fa As Long
Dim c0B As Long
Dim fl As Integer
Dim fn As Integer
Dim P As Long
Fr = Worksheets("Lagerauswahl").Range("A5").Value
Fa = Worksheets("Lagerauswahl").Range("A9").Value
d = Worksheets("Welle").Range("U10").Value
Cells(136, 42) = d
Cells(137, 42) = y
Cells(138, 42) = P
Cells(139, 42) = c0B
For Z = Cells(8, 30) To Cells(134, 30)
On Error Resume Next
If Cells(Z, 30) = d Then
Sheets("Tabellen").Cells(Z, 41).Copy
ActiveSheet.Paste Destination:=Sheets("Tabellen").Cells(137, 42)
Cells(138, 42).Value = Cells(137, 42) * Fa + Fr
Cells(139, 42).Value = Cells(138, 42) * (Cells(141, 42) / Cells(142, 42))
While Cells(139, 42).Value > Cells(Z, 34) And Cells(Z, 30).Value = d
Z = Z + 1
Sheets("Tabellen").Cells(Z, 41).Copy
ActiveSheet.Paste Destination:=Sheets("Tabellen").Cells(137, 42)
Cells(138, 42).Value = Cells(137, 42) * Fa + Fr
Cells(139, 42).Value = Cells(138, 42) * (Cells(141, 42) / Cells(142, 42))
If Cells(139, 42).Value d Then
MsgBox ("Kein Lager für diesen Wellendurchmesser vorhanden!")
GoTo ende
End If
Wend
End If
Next Z
ende:
End Function
Haut aber net ganz hin - und starten NICHT automatisch!
Ich hoffe auf Eure Hilfe, bin echt bald verzweifelt!!!
Mit einem FETTEN DANKE im Vorraus
Gruß
Hubitz
Ach ja - hier die Tabelle: https://www.herber.de/bbs/user/44237.xls
Leider passen die Spaltenbezüge nicht mehr überein, da ich die Tabelle kopiert habe. hoffe es klappt trotzdem...
THX