Next: Index Up: Multiplikation zweier Spektren Previous: Multiplikation zweier Spektren Index
![[*]](crossref.png)
erweitert um eine Funktion Integ(),
die direkt in einer Zelle aufgerufen wird und den Integralwert ausgibt.
Parameter dieser Funktion sind Bereiche der x- und y-Werte in einer beliebig langen Abfolge, so dass beliebig viele Spektren miteinander durchmultipliziert werden können.
Wenn die ersten beiden Parameter nur einfache Zahlen sind, dann werden sie als Obergrenze und Untergrenze interpretiert.
Ist der dritte Parameter "SER", dann wird jeder Wert mit der errechneten erythemwirksamen Wirkung multipliziert. Das hat speziell beim Erythem
den Vorteil, dass gar nicht interpoliert werden muss.
Um die Spektren zu sortiert zu halten ist übrigens noch der Quicksortalgorithmus angefügt.
Zur Installation einfach eine Exceldatei mit Makros, erkennbar an der Endung *.xlsm, erstellen und dort in der Visual Basic Umgebung, die man durch Alt + F11 aufruft,
das Modul Integrale_VBA_excel.bas laden. Abbildung zeigt dann den Aufruf und die Möglichkeiten der Funktion.
Der angezeigte Zelleninhalt
=Integ(B23;C23;"Ser";'80041106'!$A$9:$A$609;'80041106'!$B$9:$B$609)*10000hat folgende Bedeutung. In den Zellen B23 und C23 stehen die Ober und Intergrenzen des Integrals. Der folgende Text
"Ser" bewirkt dass im Integral gleich die Bewertung als Erythem erfolgt.
in dem Bereich '80041106 OH M 3URO 160 R 06'!$A$9:$A$609 stehen die Wellenlängen und in
'80041106 OH M 3URO 160 R 06'!$B$9:$B$609 die zugehörigen Messwerte des zu integrierenden Spektrums.
der Faktor *10000 kommt daher, dass die Spektralwerte in mW/cm
angegeben sind, das Integral jedoch in W/m erhalten werden soll.
Alternativ könnten man auch schreiben:
=Integ(B23;C23;'80041106'!$A$9:$A$609;'80041106'!$B$9:$B$609;Wirk!B16:DA16;Wirk!B17:DA17)*10000Der Unterschied ist, dass jetzt nicht zu jedem Messwert der
"Ser"-Wert hinzugerechnet wird, sondern die tabellenbasierte
Erythemfunktion im Bereich Wirk!B16:DA16;Wirk!B17:DA17 mittels Interpolation dazumultipliziert wird.
Im Ergebnis gibt es ganz geringfügige Unterschiede. Die erste Methode ist prinzipiell genauer und praktischer in der Umsetzung.
In Abbildung ist unten rechts in einem grauen Feld die Ergebnisse aus einem Messlabor aufgeführt und
dasselbe Spektrum links unten hier im Excelfile durchgerechnet.
Zugehörige Werte mit leichten Unterschieden habe ich farbig entsprechend markiert. Im Erythem gibt es Unterschiede weil das Messlabor
die Werte hier in mW/m angegeben hat.
Ansonsten sind die Unterschiede sind so gering, dass ich die Programmierung als bestätigt ansehe.
Man kann beliebig viele Spektren aneinanderreihen und die werden alle durchmultipliziert und integriert. Man spart sich damit eine Menge Platz, da die Messwerte nicht mehr kopiert werden müssen und das leidige Problem mit nicht aufeinander liegenden Stützstellen taucht auch nicht mehr auf. Hier noch der komlette Quelltext:
1 Attribute VB_Name = "Integrale_VBA_excel"
2 Option Explicit
3 Public Function Integ(ParamArray inranges() As Variant) As Double
4 Dim Ncell As Range, x As Range, y As Range
5 Dim Spektren() As Variant, Spektrum() As Variant, Multipliziert() As Variant
6 Dim Untergrenze As Double, Obergrenze As Double
7 Dim i As Long, j As Long, F As Long, imin As Long
8 Dim Wirkungsfunktion As String
9 Wirkungsfunktion = ""
10 imin = LBound(inranges)
11 '************ Hier werden die geprüft ob die ersten beiden Parameter Untergrenze oder Obergrenze sind ****************
12 Untergrenze = 0: Obergrenze = 0
13 If IsNumeric(inranges(0)) And IsNumeric(inranges(1)) Then
14 If inranges(1) > inranges(0) Then
15 Untergrenze = inranges(0): Obergrenze = inranges(1)
16 ElseIf inranges(1) < inranges(0) Then
17 Untergrenze = inranges(1): Obergrenze = inranges(0)
18 End If
19 imin = imin + 2 ' Die weiteren Parameter sind dann die Spektren, wir zählen sie deshalb statt von Null von zwei ab.
20 End If
21 '************ Hier werden die geprüft ob der anstehende Parameter ein Schlüsselwort ist ****************
22 If VarType(inranges(imin)) = vbString Then
23 Wirkungsfunktion = inranges(imin)
24 imin = imin + 1
25 End If
26 '************ Hier werden die Anzahle der verbliebenen Bereiche geprüft ob sie paarweise angegeben wurden. ****************
27 If (UBound(inranges) - imin) Mod 2 = 0 Then MsgBox "Bereiche für xy-Paarbildung immer paarweise (und jeweils gleich groß) angeben!" & vbCrLf & "Berechnung abgebrochen.": Exit Function
28 '************ Hier werden die Bereichsgrößen geprüft ****************
29 For i = imin To UBound(inranges) Step 2
30 If inranges(i).Count <> inranges(i + 1).Count Then MsgBox "Bereichepaar Nr. " & i + 1 & " unterschiedlich groß !" & vbCrLf & "( " & inranges(i).Address & " hat weniger Elemente als " & inranges(i + 1).Address & " )" & vbCrLf & "xy Paarbildung unmöglich." & vbCrLf & "Berechnung abgebrochen.": Exit Function
31 Next
32 '************ Hier werden die Einträge geprüft, ob sie alle Numerisch sind****************
33 For i = imin To UBound(inranges)
34 For Each Ncell In inranges(i)
35 If Not IsNumeric(Ncell) Then MsgBox "Nichtnumerisch in Zelle" & Ncell.Address & " !": Exit Function
36 Next Ncell
37 Next i
38 '************ Jetzt erst werden die Werte eingelesen ****************
39 ReDim Spektren((UBound(inranges) - imin + 1) / 2)
40 'ReDim Spektren(((UBound(inranges) - imin) + 1) / 2 - 1)
41 For i = imin To UBound(inranges) Step 2
42 ReDim Spektrum(1, 0): j = 1 ' j=1 Markiert, dass Spektrum(1, 0) noch nicht beschrieben ist
43 Set x = inranges(i): Set y = inranges(i + 1)
44 For F = 1 To x.Count
45 If Not CStr(x(F)) = "" And Not CStr(y(F)) = "" Then ' x und y dürfen nicht leer sein und werden sonst übersprungen.
46 If j = 0 Then
47 ReDim Preserve Spektrum(1, UBound(Spektrum, 2) + 1)
48 End If
49 j = 0 ' wird jetzt auf Null gesetzt damit anschließend das Array erweitert wird
50 Spektrum(0, UBound(Spektrum, 2)) = x(F): Spektrum(1, UBound(Spektrum, 2)) = y(F)
51 End If
52 Next F
53 Set x = Nothing: Set y = Nothing
54 Spektren((i - imin) / 2) = Spektrum
55 Next i
56 Erase Spektrum ' brauchen wir nicht mehr
57 '************ Spektren Sortieren ***************
58 For i = LBound(Spektren) To UBound(Spektren) - 1
59 Call SpektrenQuickSort(Spektren(i), LBound(Spektren(i), 2), UBound(Spektren(i), 2))
60 Next i
61 '************ Grenzen herausfinden ***************
62 If Untergrenze = 0 And Obergrenze = 0 Then ' Dann wurden keine sinnvollen Werte angegeben
63 Untergrenze = Spektren(LBound(Spektren))(0, LBound(Spektren(LBound(Spektren)), 2)) ' Untergrenze von erstem Spektrum
64 Obergrenze = Spektren(LBound(Spektren))(0, UBound(Spektren(LBound(Spektren)), 2)) ' Obergrenze von erstem Spektrum
65 Else
66 Untergrenze = IIf(Spektren(LBound(Spektren))(0, LBound(Spektren(LBound(Spektren)), 2)) > Untergrenze, Spektren(LBound(Spektren))(0, LBound(Spektren(LBound(Spektren)), 2)), Untergrenze)
67 Obergrenze = IIf(Spektren(LBound(Spektren))(0, UBound(Spektren(LBound(Spektren)), 2)) < Obergrenze, Spektren(LBound(Spektren))(0, UBound(Spektren(LBound(Spektren)), 2)), Obergrenze)
68 End If
69 For i = LBound(Spektren) + 1 To UBound(Spektren) - 1
70 Untergrenze = IIf(Untergrenze > Spektren(i)(0, LBound(Spektren(i), 2)), Untergrenze, Spektren(i)(0, LBound(Spektren(i), 2)))
71 Obergrenze = IIf(Obergrenze < Spektren(i)(0, UBound(Spektren(i), 2)), Obergrenze, Spektren(i)(0, UBound(Spektren(i), 2)))
72 Next i
73 ''Debug.Print Untergrenze, ">>>", Obergrenze
74 '************ Jetzt werden die Spektren durchmultipliziert ****************
75 ReDim Multipliziert(1, 1): Multipliziert(0, 0) = Untergrenze: Multipliziert(1, 0) = 1: Multipliziert(0, 1) = Obergrenze: Multipliziert(1, 1) = 1 'Erst mal ein Element Multipliziert auf Untergrenze setzen
76 For i = 0 To UBound(Spektren) - 1 ' Über alle Spektren
77 Multipliziert = Durchmultiplizieren(Multipliziert, Spektren(i))
78 ''Debug.Print "Multipliziert: "; UBound(Multipliziert, 2)
79 'Call PrintSpektren(Multipliziert)
80 Next i
81 'Call SpektrenQuickSort(Multipliziert, LBound(Multipliziert, 2), UBound(Multipliziert, 2) - 0)
82 '************ Integration ****************
83 Integ = 0
84 Select Case Wirkungsfunktion
85 Case "Ser"
86 For F = LBound(Multipliziert, 2) To UBound(Multipliziert, 2) - 1
87 Integ = Integ + 0.5 * (Multipliziert(1, F + 1) * Ser(Multipliziert(0, F + 1)) + Multipliziert(1, F) * Ser(Multipliziert(0, F))) * (Multipliziert(0, F + 1) - Multipliziert(0, F))
88 Next F
89 Case Else
90 For F = LBound(Multipliziert, 2) To UBound(Multipliziert, 2) - 1
91 Integ = Integ + 0.5 * (Multipliziert(1, F + 1) + Multipliziert(1, F)) * (Multipliziert(0, F + 1) - Multipliziert(0, F))
92 Next F
93 End Select
94 Erase Spektren, Multipliziert
95 End Function
96 Public Function Durchmultiplizieren(ByRef U As Variant, ByRef V As Variant) As Variant()
97 Dim F() As Variant: ReDim F(1, 0)
98 Dim i As Long, j As Long: i = 0: j = 0
99 Do While i < UBound(V, 2) And j < UBound(U, 2)
100 If V(0, i) >= U(0, j + 1) Then j = j + 1: GoTo ContinueLoop
101 If U(0, j) >= V(0, i + 1) Then i = i + 1: GoTo ContinueLoop
102 If U(0, j) = V(0, i) Then
103 If Not IsEmpty(F(1, UBound(F, 2))) Then ReDim Preserve F(1, UBound(F, 2) + 1)
104 F(0, UBound(F, 2)) = V(0, i)
105 F(1, UBound(F, 2)) = U(1, j) * V(1, i)
106 'Debug.Print i; j, F(0, UBound(F, 2)); F(1, UBound(F, 2)); "= "; U(1, j); "*"; V(1, i)
107 GoTo Weiter
108 End If
109 If U(0, j) < V(0, i) Then
110 If Not IsEmpty(F(1, UBound(F, 2))) Then ReDim Preserve F(1, UBound(F, 2) + 1)
111 F(0, UBound(F, 2)) = V(0, i)
112 F(1, UBound(F, 2)) = (U(1, j) + (U(1, j + 1) - U(1, j)) / (U(0, j + 1) - U(0, j)) * (V(0, i) - U(0, j))) * V(1, i)
113 'Debug.Print i; j, F(0, UBound(F, 2)); F(1, UBound(F, 2)); "= ("; U(1, j); "+("; U(1, j + 1); "-"; U(1, j); ")/("; U(0, j + 1); "-"; U(0, j); ")*("; V(0, i); "-"; U(0, j); "))*"; V(1, i)
114 GoTo Weiter
115 End If
116 If U(0, j) > V(0, i) Then
117 If Not IsEmpty(F(1, UBound(F, 2))) Then ReDim Preserve F(1, UBound(F, 2) + 1)
118 F(0, UBound(F, 2)) = U(0, j)
119 F(1, UBound(F, 2)) = (V(1, i) + (V(1, i + 1) - V(1, i)) / (V(0, i + 1) - V(0, i)) * (U(0, j) - V(0, i))) * U(1, j)
120 'Debug.Print i; j, F(0, UBound(F, 2)); F(1, UBound(F, 2)); "= ("; V(1, i); "+("; V(1, i + 1); "-"; V(1, i); ")/("; V(0, i + 1); "-"; V(0, i); ")*("; U(0, j); "-"; V(0, i); "))*"; U(1, j)
121 GoTo Weiter
122 End If
123 Weiter:
124 If V(0, i + 1) = U(0, j + 1) Then i = i + 1: j = j + 1: GoTo ContinueLoop
125 If V(0, i + 1) < U(0, j + 1) Then i = i + 1: GoTo ContinueLoop
126 If V(0, i + 1) > U(0, j + 1) Then j = j + 1: GoTo ContinueLoop
127 ContinueLoop:
128 Loop
129 '***************letztes Element******************
130 If j = UBound(U, 2) Then
131 i = IIf(i = 0, 1, i)
132 'Debug.Print ; ; , V(0, i); (U(1, j - 1) + (U(1, j) - U(1, j - 1)) / (U(0, j) - U(0, j - 1)) * (V(0, i) - U(0, j - 1))) * V(1, i);
133 'Debug.Print "= ("; U(1, j - 1); "+("; U(1, j); "-"; U(1, j - 1); ")/("; U(0, j); "-"; U(0, j - 1); ")*("; V(0, i); "-"; U(0, j - 1); "))*"; V(1, i)
134 If Not IsEmpty(F(1, UBound(F, 2))) Then ReDim Preserve F(1, UBound(F, 2) + 1)
135 F(0, UBound(F, 2)) = U(0, j)
136 F(1, UBound(F, 2)) = (V(1, i - 1) + (V(1, i) - V(1, i - 1)) / (V(0, i) - V(0, i - 1)) * (U(0, j) - V(0, i - 1))) * U(1, j)
137 'Debug.Print "X"
138 ElseIf i = UBound(V, 2) Then
139 j = IIf(j = 0, 1, j)
140 'Debug.Print ; ; , V(0, i); (U(1, j - 1) + (U(1, j) - U(1, j - 1)) / (U(0, j) - U(0, j - 1)) * (V(0, i) - U(0, j - 1))) * V(1, i);
141 'Debug.Print "= ("; U(1, j - 1); "+("; U(1, j); "-"; U(1, j - 1); ")/("; U(0, j); "-"; U(0, j - 1); ")*("; V(0, i); "-"; U(0, j - 1); "))*"; V(1, i)
142 If Not IsEmpty(F(1, UBound(F, 2))) Then ReDim Preserve F(1, UBound(F, 2) + 1)
143 F(0, UBound(F, 2)) = V(0, i)
144 F(1, UBound(F, 2)) = (U(1, j - 1) + (U(1, j) - U(1, j - 1)) / (U(0, j) - U(0, j - 1)) * (V(0, i) - U(0, j - 1))) * V(1, i)
145 End If
146 Durchmultiplizieren = F
147 End Function
148 Private Sub SpektrenQuickSort(ByRef ArrayToSort As Variant, ByVal Low As Long, ByVal High As Long)
149 Dim vPartition As Variant, vTemp As Variant, vTempwith As Variant, i As Long, j As Long
150 If Low > High Then Exit Sub ' Rekursions-Abbruchbedingung
151 vPartition = ArrayToSort(0, (Low + High) \ 2)
152 i = Low: j = High
153 Do
154 Do While ArrayToSort(0, i) < vPartition
155 i = i + 1
156 Loop
157 Do While ArrayToSort(0, j) > vPartition
158 j = j - 1
159 Loop
160 If i <= j Then
161 vTemp = ArrayToSort(0, j): vTempwith = ArrayToSort(1, j)
162 ArrayToSort(0, j) = ArrayToSort(0, i): ArrayToSort(1, j) = ArrayToSort(1, i)
163 ArrayToSort(0, i) = vTemp: ArrayToSort(1, i) = vTempwith
164 i = i + 1
165 j = j - 1
166 End If
167 Loop Until i > j
168 If (j - Low) < (High - i) Then
169 SpektrenQuickSort ArrayToSort, Low, j
170 SpektrenQuickSort ArrayToSort, i, High
171 Else
172 SpektrenQuickSort ArrayToSort, i, High
173 SpektrenQuickSort ArrayToSort, Low, j
174 End If
175 End Sub
176 Function Ser(x)
177 If x <= 298 Then
178 Ser = 1#
179 ElseIf x <= 328 Then
180 Ser = 10 ^ (0.094 * (298# - x))
181 ElseIf x <= 400 Then
182 Ser = 10 ^ (0.015 * (140# - x))
183 ElseIf x > 400 Then
184 Ser = 0#
185 End If
186 'Definition aus DIN 5050 Teil 1:
187 'ser = 1 für lambda <= 298 nm
188 'ser = 10^(0,094*(298-lambda)) für 298 nm < lambda <= 328 nm
189 'ser = 10^(0,015*(140-lambda)) für 328 nm < lambda <= 400 nm
190 End Function
191 Sub PrintSpektren(Spektren As Variant)
192 Dim i As Long
193 For i = 1 To UBound(Spektren, 2)
194 Debug.Print i, Spektren(0, i), Spektren(1, i)
195 Next i
196 End Sub
197
198
|