->Definition Zelle Eingabe kg
Const c_Eing_kg_SP = 6 ->Spalte F
Const c_Eing_kg_Z = 15 ->Zeile 15
->Definition Zelle Eingabe kg
Const c_Eing_km_SP = 6 ->Spalte F
Const c_Eing_km_Z = 16 ->Zeile 16
->Definition Zelle Ausgabe kg
Const c_Ausg_Preis_SP = 6->Spalte F
Const c_Ausg_Preis_Z = 17->Zeile 17
->Definition kg-Spalte : 451 -500kg
Const c_kg_SP = 1 'Spalte A
Const c_kg_Zanf = 2 'Zeile 2
Const c_kg_Zend = 12 ->Zeile 12
->Definition km-Zeile : bis 100 km
Const c_km_Z = 1 ->Zeile 1
Const c_km_SPanf = 2 ->Spalte B
Const c_km_SPend = 12 'Spalte L
'***********************************************************
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim kg As String, l_kg As Long, km As String, l_km As Long
Dim Zeile As Long, Spalte As Long, s_tmp As String
->eine Zelle geändert ?
If Target.Count = 1 Then
If (Target.Row = c_Eing_kg_Z And Target.Column = c_Eing_kg_SP) Or _
(Target.Row = c_Eing_km_Z And Target.Column = c_Eing_km_SP) Then
->kg-Zelle oder km-Zelle geändert
km = ActiveSheet.Cells(c_Eing_km_Z, c_Eing_km_SP).Value
kg = ActiveSheet.Cells(c_Eing_kg_Z, c_Eing_kg_SP).Value
If (km <> ) And (kg <> ) Then
If IsNumeric(km) And IsNumeric(kg) Then
l_km = km: l_kg = kg
Call Kreuzwertsuchen(l_kg, l_km, Zeile, Spalte)
If (Zeile > 0) And (Spalte > 0) Then
ActiveSheet.Cells(c_Ausg_Preis_Z, c_Ausg_Preis_SP).Value = _
l_kg * ActiveSheet.Cells(Zeile, Spalte).Value
Else
MsgBox (Bei der Suche ist ein Fehler ausgetreten.)
End If
Else
MsgBox (km- oder kg-Eingabe ist nicht numerisch)
End If
End If
End If
End If
Exit Sub
errorhandler:
MsgBox (Es ist unerwartet Fehler & Err.Number & aufgetreten.)
Err.Clear
On Error GoTo 0
End Sub
'***********************************************************
Function Kreuzwertsuchen(kg_Wert_Eing As Long, km_Wert_Eing As Long, _
Zeile As Long, Spalte As Long)
->sucht den kg-Wert und den km_wert und
->gibt Zeile/Spalte des Kreuzproduktes zurück
->Eingang:kg_Wert_Eing,km_Wert_Eing
->Ausgang:Zeile, Spalte des Kreuzproduktes
->Fehler :Zeile und/oder Spalte -1
'***********************************************************
Dim z As Long, kg_von As Long, kg_bis As Long
Dim sp As Long, km_bis As Long
Zeile = -1: Spalte = -1
->Zeile kg-Wert suchen
For z = c_kg_Zanf To c_kg_Zend
Call kgStringInWert(ActiveSheet.Cells(z, c_kg_SP).Value, kg_von, kg_bis)
If (kg_von < 0) Or (kg_bis < 0) Then Exit Function->Fehler?
If (kg_von <= kg_Wert_Eing) And (kg_Wert_Eing <= kg_bis) Then
->innerhalb des Intervals -> Wert gefunden
Zeile = z
Exit For
Else
->Wenn bis zur letzten Zeile nicht gefunden -> letzte Zeile wählen
If z = c_kg_Zend Then Zeile = z
End If
Next
->Spalte km-Wert suchen
For sp = c_km_SPanf To c_km_SPend
Call kmStringInWert(ActiveSheet.Cells(c_km_Z, sp).Value, km_bis)
If (km_bis < 0) Then Exit Function ->Fehler?
If km_bis >= km_Wert_Eing Then
Spalte = sp
Exit For
Else
'Wenn bis zur letzten Spaltee nicht gefunden -> letzte Spalte wählen
If sp = c_km_SPend Then Spalte = sp
End If
Next
End Function
'***********************************************************
Function kgStringInWert(kg_str As String, kg_von As Long, kg_bis As Long)
->Input : String der Form: 451 - 500 kg
->Output: kg_von : 451
-> kg_bis : 500
->Fehler: kg_von : 0
'***********************************************************
Const c_kg_Trennzeichen = -
Const c_kg_Einheit = kg
Dim pos1 As Long, pos2 As Long, s_tmp1 As String, s_tmp2 As String
->Fehlerkennung vorbesetzen
kg_von = -1: kg_bis = -1
->Trennzeichen Position feststellen
pos1 = InStr(1, kg_str, c_kg_Trennzeichen)
If pos1 > 0 Then
->k9 Position feststellen
pos2 = InStr(1, kg_str, c_kg_Einheit)
If pos2 > 0 Then
->Zahlen ausschneiden
s_tmp1 = Left(kg_str, pos1 - 1)
s_tmp2 = Mid(kg_str, _
pos1 + Len(c_kg_Trennzeichen), _
(pos2 - 1) - (pos1 - 1 + Len(c_kg_Trennzeichen)))
->alle Leerzeichen entfernen
pos1 = InStr(1, s_tmp1, )
Do While pos1 > 0
s_tmp1 = Left(s_tmp1, pos1 - 1) & Right(s_tmp1, Len(s_tmp1) - pos1)
pos1 = InStr(1, s_tmp1, )
Loop
pos1 = InStr(1, s_tmp2, )
Do While pos1 > 0
s_tmp2 = Left(s_tmp2, pos1 - 1) & Right(s_tmp2, Len(s_tmp2) - pos1)
pos1 = InStr(1, s_tmp2, )
Loop
If IsNumeric(s_tmp1) Then kg_von = s_tmp1
If IsNumeric(s_tmp2) Then kg_bis = s_tmp2
End If
End If
End Function
'***********************************************************
Function kmStringInWert(km_str As String, km_wert As Long)
->Input : String der Form: bis 100 km
->Output: km_wert : 100
->Fehler: km_wert : -1
'***********************************************************
Const c_km_Trennzeichen As String = bis
Const c_km_Einheit As String = km
Dim pos1 As Long, pos2 As Long, s_tmp As String
->Fehlerkennung vorbesetzen
km_wert = -1
->bis Position feststellen
pos1 = InStr(1, km_str, c_km_Trennzeichen)
If pos1 > 0 Then
->km Position feststellen
pos2 = InStr(1, km_str, c_km_Einheit)
If pos2 > 0 Then
->Zahl ausschneiden
s_tmp = Mid(km_str, _
pos1 + Len(c_km_Trennzeichen), _
(pos2 - 1) - (pos1 - 1 + Len(c_km_Trennzeichen)))
->alle Leerzeichen entfernen
pos1 = InStr(1, s_tmp, )
Do While pos1 > 0
s_tmp = Left(s_tmp, pos1 - 1) & Right(s_tmp, Len(s_tmp) - pos1)
pos1 = InStr(1, s_tmp, )
Loop
If IsNumeric(s_tmp) Then km_wert = s_tmp
End If
End If
End Function
