AW: Allergen-Liste (Buchstaben)
08.10.2015 14:44:33
fcs
Hallo Debian,
du musst meinen Vorschlag in das Blatt Leerrezept einbauen!!!!!! Nicht "Inventar".
Die Formeln in den Spalten O und P im Blatt Leerrezept holen Informationen aus dem Blatt "Inventar" - genau so, wie in den Spalten B und die Informationen zu Portionsgröße und Bruttopreisen per Formel geholt werden.
Diese Informationen muss man dann weiterverarbeiten.
Bei den Allergenen geht das in meiner Lösung über die Daten und Formeln in den Spalten Q bis S oder mit dem geposteten Makro.
Wenn diese Spalten stören beim Ausdruck, dann kannst du sie ja auch ausblenden.
Wie bereits angedeutet, kann man das Makro auch soweit erweitern, dass es die Daten in der Inventarliste direkt auswertet. Aber das geht dann auf Kosten der Rechengeschwindigkeit, weil langsames VBA schnelle Excelfunktionen ersetzt.
Wenn du die große VBA-Lösung suchst, dann verwende die folgenden VBA-Funktionen.
Gruß
Franz
Leer-Rezept
| B | C |
14 | Allergene | A,C |
15 | | nur für Fleischesser |
Formeln der Tabelle |
Zelle | Formel | C14 | =fncAllergene(C18:C35;Inventar!$C$2:$E$5000;3) | C15 | =fncVegetarischVegan(C18:C35;Inventar!$C$2:$G$5000;4;5;"X";"-";;;"nur für Fleischesser") |
|
Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8
'allgemeines Modul "Modul_Allergen"
Option Explicit
Public Function fncAllergene(rngZutaten As Range, rngInventar, SpaAllergen As Long, _
Optional strSep As String = ",", _
Optional Fuellzeichen As String = "-") As String
'rngZutaten= 1-spaltiger Zellbereich mit den Zutatten
'rngInventar = Zellbereich mit den Zutaten in Spalte 1 _
und den Allergen-Kennbuchstaben in der Spalte SpaAllergen
'SpaAllergen = Nummer der Spalte mit den Allergenen innerhalb von rngInventar
'strSep = Trennzeichen zwischen Allergenen, wenn eine Zutat mehreren Allergene _
enthält
'Fuellzeichen = Text, der in Zelle stehen kann, wenn keine Zutat eingetragen ist
'Formelbeispiel: =fncAllergene(C18:C35;Inventar!$C$2:$E$5000;3) _
=fncAllergene(C18:C35;Inventar!$C$2:$E$5000;3; ","; "-")
Dim Zeile As Variant, Zelle As Range
Dim arrSplit As Variant
Dim objCol As New Collection
Dim strErgebnis As String
On Error GoTo Fehler
For Each Zelle In rngZutaten.Columns(1).Cells
If Not (Trim(Zelle = "") Or Zelle.Text = Fuellzeichen) Then
Zeile = Application.Match(Zelle.Text, rngInventar.Columns(1), 0)
If IsNumeric(Zeile) Then
With rngInventar.Cells(Zeile, SpaAllergen)
If Trim(.Text) "" Then
If strErgebnis = "" Then
strErgebnis = Trim(.Text)
Else
strErgebnis = strErgebnis & strSep & Trim(.Text)
End If
End If
End With
Else
fncAllergene = "#NV"
Exit Function
End If
End If
Next Zelle
If Trim(strErgebnis = "") Then
fncAllergene = "-keine-"
Else
If InStr(1, strErgebnis, strSep) = 0 Then
fncAllergene = Trim(strErgebnis)
Else
arrSplit = Split(strErgebnis, strSep)
strErgebnis = ""
For Zeile = LBound(arrSplit) To UBound(arrSplit)
objCol.Add Trim(arrSplit(Zeile)), Trim(arrSplit(Zeile))
If strErgebnis = "" Then
strErgebnis = Trim(arrSplit(Zeile))
Else
strErgebnis = strErgebnis & strSep & Trim(arrSplit(Zeile))
End If
Next_Zeile:
Next Zeile
If InStr(1, strErgebnis, strSep) = 0 Then
fncAllergene = Trim(strErgebnis)
Else
arrSplit = Split(strErgebnis, strSep)
Call Quicksort(arrSplit, LBound(arrSplit), UBound(arrSplit))
arrSplit = Split(strErgebnis, strSep)
strErgebnis = ""
For Zeile = LBound(arrSplit) To UBound(arrSplit)
If strErgebnis = "" Then
strErgebnis = Trim(arrSplit(Zeile))
Else
strErgebnis = strErgebnis & strSep & Trim(arrSplit(Zeile))
End If
Next
fncAllergene = strErgebnis
End If
End If
End If
Fehler:
With Err
Select Case .Number
Case 0 'alle OK
Case 457 'doppelter Key in Collection
Resume Next_Zeile
Case Else
' MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly, "Function: fncAllergene" ' nur zum Testen
fncAllergene = "#FEHLER#"
End Select
End With
End Function
Public Function fncVegetarischVegan(rngZutaten As Range, rngInventar, _
SpaVeg As Long, SpaVegan As Long, _
Optional strMarker As String = "X", _
Optional Fuellzeichen As String = "-", _
Optional ErgebnisVegan As String = "vegan", _
Optional ErgebnisVegetarisch As String = "vegetarisch", _
Optional ErgebnisAnderes As String = "nicht vegetarisch") As String
'rngZutaten = 1-spaltiger Zellbereich mit den Zutatten
'rngInventar = Zellbereich mit den Zutaten in Spalte 1 _
und den Markierung für "vegetarisch" in der Spalte SpaVeg _
und der Markierung für "vegan" in der Spalte SpaVegan
'SpaVeg = Nummer der Spalte mit Markierung für vegetarisch
'SpaVegan = Nummer der Spalte mit Markierung für vegan
'strMarker = Zeichen zur Markierung, ob eine Zutat vegan/vegetarisch ist
'Fuellzeichen = Text, der in Zelle stehen kann, wenn keine Zutat eingetragen ist
'Formelbeispiel:
'=fncVegetarischVegan(C18:C35;Inventar!$C$2:$G$5000;4;5;"X";"-")
Dim Zeile As Variant, Zelle As Range
Dim strErgebnis As String
On Error GoTo Fehler
strErgebnis = ErgebnisVegan
For Each Zelle In rngZutaten.Columns(1).Cells
If Not (Trim(Zelle = "") Or Zelle.Text = Fuellzeichen) Then
Zeile = Application.Match(Zelle.Text, _
rngInventar.Columns(1), 0)
If IsNumeric(Zeile) Then
With rngInventar.Cells(Zeile, SpaVegan)
If UCase(Trim(.Text)) UCase(strMarker) Then
strErgebnis = ErgebnisVegetarisch
With rngInventar.Cells(Zeile, SpaVeg)
If UCase(Trim(.Text)) UCase(strMarker) Then
strErgebnis = ErgebnisAnderes
Exit For
End If
End With
End If
End With
Else
strErgebnis = "#NV"
Exit For
End If
End If
Next Zelle
fncVegetarischVegan = strErgebnis
Fehler:
With Err
Select Case .Number
Case 0 'alle OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly, "Function: fncVegetarischVegan" ' nur zum Testen
fncVegetarischVegan = "#FEHLER#"
End Select
End With
End Function
Public Function Quicksort(Data, links, rechts)
'Sortieren einer einspaltigen Datenliste
'links und rechts geben die Nummern der der Elemente an, die sortiert werden sollen
'normalerweise nimmt man das 1. und letzte Element
Dim Teiler As Long
If rechts > links Then
Teiler = Teile(Data, links, rechts)
Call Quicksort(Data, links, Teiler - 1)
Call Quicksort(Data, Teiler + 1, rechts)
End If
End Function
Private Function Teile(Data, links, rechts)
Dim Index As Long
Dim i As Long
Index = links
For i = links To rechts - 1
If Data(i)