Option Explicit
Type myWineCard_Struct
Year As String
Name As String
Variety As String
Size As String
End Type
Private Const cBLT_ANZAHL = 3-> Anzahl der Blätter mit Weinkarte
-> in Function Blattparameter muessen die Parameter gesetzt werden
Public Const cRETURN_OK = 0
Public Const cRETURN_TERMINATE = -1
Public lReturn_UF_SearchWine As Long
Public Const cSTR_NICHTSAUSGEWAEHLT = nothing selected
Public bODERPRUEFUNG As Boolean
'Gelesene Listen
Public WC() As myWineCard_Struct, WCCnt As Long
Public WCYear() As String, WCYearCnt As Long
Public WCName() As String, WCNameCnt As Long
Public WCVariety() As String, WCVarietyCnt As Long
Public WCSize() As String, WCSizeCnt As Long
'Listen mit Suchbegriffen
Public SRCHYear() As String, SRCHYearCnt As Long
Public SRCHName() As String, SRCHNameCnt As Long
Public SRCHVariety() As String, SRCHVarietyCnt As Long
Public SRCHSize() As String, SRCHSizeCnt As Long
Sub MyWineSearch()
Application.ScreenUpdating = False
Call LesenDerWeinkarte
If Not SuchbegriffeHolen Then GoTo Aufraeumen
Call ZeilenOhneSuchbegriffenAuslenden
Aufraeumen:
Application.ScreenUpdating = True
End Sub
'*************************************************************************************
Private Function Blattparameter(lLfdWeinkarte As Long, _
sBLTName As String, _
lZ_UEBSCHR As Long, lZ_1Z As Long, _
lSP_Year As Long, lSP_Name As Long, _
lSP_Variety As Long, lSP_Size As Long)
->Hier kannst du Blattparameter für verschiedene Blätter der Weinliste eingeben
->Es werden alle Blätter von 1 to cBLT_ANZAHL abgefahren
Select Case lLfdWeinkarte
Case 1
->Blattbeschreibung 1.Blatt
sBLTName = TableOfWine
lZ_UEBSCHR = 2: lZ_1Z = 3-> erste Wertezeile
lSP_Year = 1: lSP_Name = 2: lSP_Variety = 3: lSP_Size = 4
Case 2
->Blattbeschreibung 2.Blatt
sBLTName = TableOfWine2
lZ_UEBSCHR = 2: lZ_1Z = 3-> erste Wertezeile
lSP_Year = 3: lSP_Name = 4: lSP_Variety = 5: lSP_Size = 6
Case 3
->Blattbeschreibung 3.Blatt
sBLTName = TableOfWine3
lZ_UEBSCHR = 2: lZ_1Z = 3-> erste Wertezeile
lSP_Year = 2: lSP_Name = 3: lSP_Variety = 4: lSP_Size = 5
End Select
End Function
'*************************************************************************************
Private Function ZeilenOhneSuchbegriffenAuslenden()
Dim ws As Worksheet
Dim lrows As Long, x As Long, b As Long
Dim sYear As String, sName As String, sVariety As String, sSize As String
->Blattbeschreibung
Dim sBLTName As String
Dim lZ_UEBSCHR As Long, lZ_1Z As Long
Dim lSP_Year As Long, lSP_Name As Long, lSP_Variety As Long, lSP_Size As Long
If (SRCHYearCnt = 0) And _
(SRCHNameCnt = 0) And _
(SRCHVarietyCnt = 0) And _
(SRCHSizeCnt = 0) Then GoTo Aufraeumen
For b = 1 To cBLT_ANZAHL
Call Blattparameter(b, sBLTName, lZ_UEBSCHR, lZ_1Z, lSP_Year, lSP_Name, lSP_Variety, lSP_Size)
Set ws = ActiveWorkbook.Worksheets(sBLTName)
lrows = ZeilenZahlWeinkarteBestimmen(ws, lSP_Year, lSP_Name, lSP_Variety, lSP_Size)
If bODERPRUEFUNG Then
ws.Rows(lZ_1Z & : & lrows).Hidden = False
Else
ws.Rows(lZ_1Z & : & lrows).Hidden = True
End If
For x = lrows To lZ_1Z Step -1
sYear = ws.Cells(x, lSP_Year).Value: TrimMe (sYear)
sName = ws.Cells(x, lSP_Name).Value: TrimMe (sName)
sVariety = ws.Cells(x, lSP_Variety).Value: TrimMe (sVariety)
sSize = ws.Cells(x, lSP_Size).Value: TrimMe (sSize)
If bODERPRUEFUNG Then
->wenn kein Suchbegriff trifft ausblenden (ODER)
If (Not IstSuchbegriff(SRCHYear(), SRCHYearCnt, sYear)) And _
(Not IstSuchbegriff(SRCHName(), SRCHNameCnt, sName)) And _
(Not IstSuchbegriff(SRCHVariety(), SRCHVarietyCnt, sVariety)) And _
(Not IstSuchbegriff(SRCHSize(), SRCHSizeCnt, sSize)) Then _
ws.Rows(x).Hidden = True
Else
->wenn ein Suchbegriff nicht trifft ausblenden (UND)
If (IstSuchbegriff2(SRCHYear(), SRCHYearCnt, sYear)) And _
(IstSuchbegriff2(SRCHName(), SRCHNameCnt, sName)) And _
(IstSuchbegriff2(SRCHVariety(), SRCHVarietyCnt, sVariety)) And _
(IstSuchbegriff2(SRCHSize(), SRCHSizeCnt, sSize)) Then _
ws.Rows(x).Hidden = False
End If
Next
Next
Aufraeumen:
Set ws = Nothing
End Function
'*************************************************************************************
Private Function IstSuchbegriff2(f() As String, fcnt As Long, s As String) As Boolean
Dim x As Long
If fcnt = 0 Then IstSuchbegriff2 = True: Exit Function
IstSuchbegriff2 = False
For x = 1 To fcnt
If f(x) = s Then IstSuchbegriff2 = True: Exit Function
Next
End Function
'*************************************************************************************
Private Function IstSuchbegriff(f() As String, fcnt As Long, s As String) As Boolean
Dim x As Long
IstSuchbegriff = False
For x = 1 To fcnt
If f(x) = s Then IstSuchbegriff = True: Exit Function
Next
End Function
'*************************************************************************************
Private Function SuchbegriffeHolen() As Boolean
Dim x As Long
SRCHYearCnt = 0: SRCHNameCnt = 0: SRCHVarietyCnt = 0: SRCHSizeCnt = 0
Load Uf_SearchForWine
Call SuchbegriffeInDorpdownListenSchreiben(Uf_SearchForWine, Year, WCYear(), WCYearCnt)
Call SuchbegriffeInDorpdownListenSchreiben(Uf_SearchForWine, Name, WCName(), WCNameCnt)
Call SuchbegriffeInDorpdownListenSchreiben(Uf_SearchForWine, Variety, WCVariety(), WCVarietyCnt)
Call SuchbegriffeInDorpdownListenSchreiben(Uf_SearchForWine, Size, WCSize(), WCSizeCnt)
lReturn_UF_SearchWine = cRETURN_TERMINATE
Uf_SearchForWine.Show
If lReturn_UF_SearchWine <> cRETURN_OK Then Unload Uf_SearchForWine: Exit Function
->Suchbegriffe feststellen
Call SuchbegriffeAusDorpdownListenLesen(Uf_SearchForWine, Year, SRCHYear(), SRCHYearCnt)
Call SuchbegriffeAusDorpdownListenLesen(Uf_SearchForWine, Name, SRCHName(), SRCHNameCnt)
Call SuchbegriffeAusDorpdownListenLesen(Uf_SearchForWine, Variety, SRCHVariety(), SRCHVarietyCnt)
Call SuchbegriffeAusDorpdownListenLesen(Uf_SearchForWine, Size, SRCHSize(), SRCHSizeCnt)
->Mode für die Verknüpfung der Spalten
bODERPRUEFUNG = Uf_SearchForWine.OB_ModeOR.Value
SuchbegriffeHolen = True
Aufraeumen:
Unload Uf_SearchForWine
End Function
'*************************************************************************************
Private Function SuchbegriffeAusDorpdownListenLesen( _
UF As UserForm, sObj As String, f() As String, fcnt As Long)
Dim x As Long, y As Long, bFound As Boolean
fcnt = 0: ReDim f(1 To 1)
For x = 1 To 5
If UF.Controls(CB & x & sObj).ListIndex > 0 Then
If UF.Controls(CB & x & sObj).Text <> Then
bFound = False
For y = 1 To fcnt
If f(y) = UF.Controls(CB & x & sObj).Text Then bFound = True: Exit For
Next
If Not bFound Then
fcnt = fcnt + 1: ReDim Preserve f(1 To fcnt)
f(fcnt) = UF.Controls(CB & x & sObj).Text
End If
End If
End If
Next
End Function
'*************************************************************************************
Private Function SuchbegriffeInDorpdownListenSchreiben( _
UF As UserForm, sObj As String, f() As String, fcnt As Long)
Dim x As Long
UF.Controls(CB1 & sObj).AddItem cSTR_NICHTSAUSGEWAEHLT
For x = 1 To fcnt: UF.Controls(CB1 & sObj).AddItem f(x): Next
UF.Controls(CB1 & sObj).ListIndex = 0
For x = 2 To 5
UF.Controls(CB & x & sObj).List = UF.Controls(CB1 & sObj).List
UF.Controls(CB & x & sObj).ListIndex = 0
Next
End Function
'*************************************************************************************
Private Function ZeilenZahlWeinkarteBestimmen(ws As Worksheet, _
lSP_Year As Long, lSP_Name As Long, _
lSP_Variety As Long, lSP_Size As Long) As Long
Dim lrows As Long, x As Long, sp As Long
->Zeilenanzahl bestimmen
lrows = 0
For x = 1 To 4
Select Case x
Case 1: sp = lSP_Year
Case 2: sp = lSP_Name
Case 3: sp = lSP_Variety
Case 4: sp = lSP_Size
End Select
If lrows < ws.Cells(ws.Rows.Count, sp).End(xlUp).Row Then lrows = ws.Cells(ws.Rows.Count, sp).End(xlUp).Row
Next
ZeilenZahlWeinkarteBestimmen = lrows
End Function
'*************************************************************************************
Private Function LesenDerWeinkarte() As Boolean
Dim ws As Worksheet
Dim lrows As Long, x As Long, sp As Long, b As Long
Dim sYear As String, sName As String, sVariety As String, sSize As String
Dim sBLTName As String
Dim lZ_UEBSCHR As Long, lZ_1Z As Long
Dim lSP_Year As Long, lSP_Name As Long, lSP_Variety As Long, lSP_Size As Long
WCCnt = 0: ReDim WC(1 To 1)
WCYearCnt = 0: ReDim WCYear(1 To 1)
WCNameCnt = 0: ReDim WCName(1 To 1)
WCVarietyCnt = 0: ReDim WCVariety(1 To 1)
WCSizeCnt = 0: ReDim WCSize(1 To 1)
For b = 1 To cBLT_ANZAHL
Call Blattparameter(b, sBLTName, lZ_UEBSCHR, lZ_1Z, lSP_Year, lSP_Name, lSP_Variety, lSP_Size)
Set ws = ActiveWorkbook.Worksheets(sBLTName)
ws.Rows.Hidden = False
->Zeilenanzahl bestimmen
lrows = ZeilenZahlWeinkarteBestimmen(ws, lSP_Year, lSP_Name, lSP_Variety, lSP_Size)
For x = lZ_1Z To lrows
->Begriffe as Zeile
sYear = ws.Cells(x, lSP_Year).Value: TrimMe (sYear)
sName = ws.Cells(x, lSP_Name).Value: TrimMe (sName)
sVariety = ws.Cells(x, lSP_Variety).Value: TrimMe (sVariety)
sSize = ws.Cells(x, lSP_Size).Value: TrimMe (sSize)
If sYear = And sName = And sVariety = And sSize = Then GoTo NAECHSTEZEILE
->in Struktur eintragen
WCCnt = WCCnt + 1
If WCCnt > UBound(WC()) Then ReDim Preserve WC(1 To WCCnt + 10)
WC(WCCnt).Year = sYear
WC(WCCnt).Name = sName
WC(WCCnt).Variety = sVariety
WC(WCCnt).Size = sSize
->in Liste eintragen, wenn noch nicht vorhanden
Call MakeListOfDifferentMembers(WCYear(), WCYearCnt, sYear)
Call MakeListOfDifferentMembers(WCName(), WCNameCnt, sName)
Call MakeListOfDifferentMembers(WCVariety(), WCVarietyCnt, sVariety)
Call MakeListOfDifferentMembers(WCSize(), WCSizeCnt, sSize)
NAECHSTEZEILE:
Next
Next
If WCCnt = 0 Then MsgBox Winecards empty: GoTo Aufraeumen
If WCYearCnt = 0 Then MsgBox Columns->Year' empty: GoTo Aufraeumen
If WCNameCnt = 0 Then MsgBox Columns->Name' empty: GoTo Aufraeumen
If WCVarietyCnt = 0 Then MsgBox Columns->Variety' empty: GoTo Aufraeumen
If WCSizeCnt = 0 Then MsgBox Columns->Size' empty: GoTo Aufraeumen
Call StringListSort(WCYear(), WCYearCnt, False)
Call StringListSort(WCName(), WCNameCnt, True)
Call StringListSort(WCVariety(), WCVarietyCnt, True)
Call StringListSort(WCSize(), WCSizeCnt, False)
LesenDerWeinkarte = True
Aufraeumen:
Set ws = Nothing
End Function
'*************************************************************************************
Private Function StringListSort(f() As String, fcnt As Long, bLinksSortieren As Boolean)
Dim sTmp As String, s1 As String, s2 As String
Dim x As Long, y As Long
Dim bSort As Boolean
Const lMAXSTRLNG = 100
If fcnt < 2 Then Exit Function
For x = 1 To fcnt
For y = x + 1 To fcnt
bSort = False
If bLinksSortieren Then
s1 = f(x) & String(lMAXSTRLNG - Len(f(x)), Chr(32))
s2 = f(y) & String(lMAXSTRLNG - Len(f(y)), Chr(32))
If s1 > s2 Then bSort = True
Else
s1 = String(lMAXSTRLNG - Len(f(x)), Chr(32)) & f(x)
s2 = String(lMAXSTRLNG - Len(f(y)), Chr(32)) & f(y)
If s1 > s2 Then bSort = True
End If
If bSort Then sTmp = f(x): f(x) = f(y): f(y) = sTmp
Next
Next
End Function
'*************************************************************************************
Private Function MakeListOfDifferentMembers(f() As String, fcnt As Long, s As String)
Dim x As Long, bFound As Boolean
bFound = False
For x = 1 To fcnt
If f(x) = s Then bFound = True: Exit For
Next
If Not bFound Then
fcnt = fcnt + 1
If fcnt > UBound(f()) Then ReDim Preserve f(1 To fcnt + 10)
f(fcnt) = s
End If
End Function
'*************************************************************************************
Function TrimMe(sText As String)
Dim lLen As Long, x As Long
lLen = Len(sText)
If lLen = 0 Then Exit Function
For x = 1 To lLen
If Chr(32) = Mid(sText, 1, 1) Then sText = Right(sText, Len(sText) - 1)
Next
lLen = Len(sText)
If lLen = 0 Then Exit Function
For x = 1 To lLen
If Chr(32) = Mid(sText, Len(sText), 1) Then sText = Left(sText, Len(sText) - 1)
Next
End Function
