Ok dann versuche ich es einmal.
Ich habe eine Userform mit dieser suche ich nach Nummern.
diese gefundenen nummern gebe ich in einer Listbox aus:
Jetzt habe ich ein Problem.
Ich soll den code so ändern das in der Listbox nicht nur die ÄNummer angezeigt wird sondern auch andere Daten die davor aus einer Exceldatenbank in ein Array ausgelesen wurde.
Diese Kompletten daten stehen in diesem Array:
arrTmp1 = .Range(.Cells(3, 2), .Cells(x1, y1))
arrTmp1 = WorksheetFunction.Transpose(arrTmp1)
Dort stehen alle werte aus meheren Spalten aus der ExcelDatenbank.
Auch die ÄNummer die momentan angezeigt wird.
Ich benötige jetzt aber in der listbox noch weitere werte.
diese Zum Beispiel aus Spalte 1(ÄNummer) dann Spalte2 ONummer und Spalte3(Infotext)
Diese daten benötige ich dann in der Listbox ausgegeben.
Ich hoffe es kann jemand mit meiner erklärung etwas anfangen.
es ist mir leider nicht5 möglich die Ganze Datei ins Forum zu kopieren.
Vielen Dank ich wäre supper glücklich und dankbar !
Dim arrTmp1, arrTmp2(), arrtmp11, i As Integer, strSuch As String, x1 As Long, n As Long
Dim datum_start As Date
Dim datum_ende As Date
Dim datum_akt As Date
Dim werks
Dim contr As Controls
Dim ListArray1
Dim ii As Integer
Dim werkgenau
Dim z
Dim y1 As Integer
Dim X
Dim x2
Dim welche_suche As Integer
Dim array_ohne_leerzellen()
Dim UF As New CUserForm
Private Sub genehmigte_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub nicht_genehmigte_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub UserForm_Activate()
'Erstelle Main Form Design (Min & Max buttons)
With UF
.MaxButton = True
.MinButton = True
.BorderStyle = xlSolid
.Create Me
End With
End Sub
Private Sub UserForm_Initialize()
'Userform erstellen prüfen welche Nummer gesucht werden soll (Änder oder Oracle)
If main_project_form.btn_find_changenumber.Tag = "ok" Then
Me.sel_nummer.Caption = "selektierte ÄnderungsNummer" 'Frame Caption vergeben für suche Ä _
nderungsnummer
Me.Label3.Caption = "Eingabe Änderungsnummer" 'Caption vergeben für suche Änderungsnummer
Me.Caption = "ÄnderungsNummer suchen ..."
welche_suche = 1 'Wichtig für spätere suche welcher bereich in Array durchsucht wird
End If
If main_project_form.btn_find_oraclenumber.Tag = "ok" Then
Me.sel_nummer.Caption = "selektierte OracleNummer" 'Frame Caption vergeben für suche _
OracleNummer
Me.Label3.Caption = "Eingabe Oraclenummer" 'Caption vergeben für suche Änderungsnummer
Me.Caption = "OracleNummer suchen ..."
welche_suche = 2 'Wichtig für spätere suche welcher bereich in Array durchsucht wird
End If
werke.List = obj_datenbank.Worksheets(2).Range("werke").Value
End Sub
'Bei Manueller suche Eingabe der Änderungs oder OracleNummer
'Änderungsnummer in Oracle anzeigen
Private Sub nr_anzeigen_btn_Click()
'Zum anzeigen aktuell gewählter Änderungs- Oracle Nummer in Main Form
nummer_anzeigen (Me.tb_nummer.Value)
End Sub
'bei Doppelklick auf Label mit ÄnderungsNummer oder OracleNummer
Private Sub selectet_numbers_lb_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'Zum anzeigen aktuell gewählter Änderungs- Oracle Nummer in Main Form
nummer_anzeigen (Me.selectet_numbers_lb.Value)
End Sub
'bei Klick auf Button um ausgewählten Eintrag von Listbox anzuzeigen
Private Sub Zeige_ae_nummer_btn_Click()
'Zum anzeigen aktuell gewählter Änderungs- Oracle Nummer in Main Form
nummer_anzeigen (Me.selectet_numbers_lb.Value)
End Sub
'Zum anzeigen aktuell gewählter Änderungs- Oracle Nummer in Main Form
Sub nummer_anzeigen(nummer)
Dim aenumbers
Dim ornumbers
Dim s As Integer
s = 0
If welche_suche = 1 Then
For Each aenumbers In main_project_form.cbo_changenumber.List
If UCase(nummer) = UCase(aenumbers) Then
' Me.Hide
main_project_form.cbo_changenumber.ListIndex = s
' Unload Me
Exit For
Else
s = s + 1
End If
Next
Else
For Each ornumbers In main_project_form.cbo_oraclenumber.List
If UCase(nummer) = UCase(ornumbers) Then
' Me.Hide
main_project_form.cbo_oraclenumber.ListIndex = s
' Unload Me
Exit For
Else
s = s + 1
End If
Next
End If
End Sub
Private Sub stammtext_ok_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub ae_erstellt_bis_dat_Change()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.beauftragter_name.SetFocus
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub ae_erstellt_von_dat_Change()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.beauftragter_name.SetFocus
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub ae_erstellt_von_dat_DropButtonClick()
kalender_form.Show
If kalender_form.Tag = "ok" Then 'Wenn OK geklickt wurde auf Vorgänger Form dann datum _
eintragen
If kalender_form.Calendar1.Day = 0 Or kalender_form.Calendar1.Month = 0 Or kalender_form. _
Calendar1.Year = 0 Then
Me.beauftragter_name.SetFocus
Exit Sub
Else
End If
Me.ae_erstellt_von_dat.Value = kalender_form.Calendar1.Day & "." & kalender_form.Calendar1. _
Month & "." & kalender_form.Calendar1.Year
Me.beauftragter_name.SetFocus
Else
Me.beauftragter_name.SetFocus
End If
End Sub
Private Sub ae_erstellt_bis_dat_DropButtonClick()
kalender_form.Show
If kalender_form.Tag = "ok" Then 'Wenn OK geklickt wurde auf Vorgänger Form dann datum _
eintragen
If kalender_form.Calendar1.Day = 0 Or kalender_form.Calendar1.Month = 0 Or kalender_form. _
Calendar1.Year = 0 Then
Me.beauftragter_name.SetFocus
Exit Sub
Else
End If
ae_erstellt_bis_dat.Value = kalender_form.Calendar1.Day & "." & kalender_form.Calendar1. _
Month & "." & kalender_form.Calendar1.Year
Else
Me.beauftragter_name.SetFocus
End If
End Sub
Private Sub mv_btn_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub piezo_btn_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub techn_btn_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub proz_btn_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub werke_Change()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub stammtext_ok_btn_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub name_ok_btn_Click()
'ruft Haupt Function ListArray auf um Daten zu filtern die benötigt werden
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub abbruch_Click()
Me.Hide
Unload Me
End Sub
'-------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------
'----------------------------------- Haupt - FUNKTION -----------------------------------------------------------
'ruft die einzelnen Unterfunktionen(Kriterien) auf
Function ListArray()
'Zuerst prüfen ob ein Bauteil gewählt wurde. Ohne diese Auswahl keine weiter funktion
If Not (mv_btn Or piezo_btn) Then
MsgBox ("Bitte zuerst Bauteil wählen "), vbCritical, "abbruch"
Unload Me
find_changenumber_form.Show
ListArray = Array("")
Exit Function
End If
'Warten Userform aufrufen bis suche fertig
wait_form.Caption = "bitte warten ..."
wait_form.Label1.Caption = "bitte warten ... please wait"
wait_form.Show
wait_form.Repaint
'Kompletten Daten in Array eintragen aus Exceldatenbank
With obj_datenbank.Worksheets(1)
x1 = .Cells(.Rows.Count, 2).End(xlUp).Row
'Letzte Spalte mit Daten ermitteln
y1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
'For y1 = .Columns.Count To 1 Step -1
' If Application.WorksheetFunction.CountA(.Columns(y1)) > 0 Then Exit For
'Next y1
'Array füllen über Spalten in Datenbank mit Daten
arrTmp1 = .Range(.Cells(3, 2), .Cells(x1, y1))
arrTmp1 = WorksheetFunction.Transpose(arrTmp1)
End With
n = -1
If piezo_btn = True Then strSuch = "F" ' Bauteil PIEZO Düse wurde gewählt
If mv_btn = True Then strSuch = "4" ' Bauteil MV Düse wurde gewählt
ListArray1 = ListArray_bauteil() 'Function aufrufen um aus Gesamtem Array nur gewähltes Bauteil zu finden
If IsEmptyArray(ListArray1) = False Then
QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
ListArray1 = ListArray_aenderstatus() 'Function aufrufen um aus Gesamtem array nur gewähltes beuteil zu finden
If IsEmptyArray(ListArray1) = False Then
QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray) = True Then GoTo ende_function
ListArray1 = ListArray_techn_or_proz() 'Function aufrufen um aus Gesamtem array nur proz oder technische änderungen zu finden
If IsEmptyArray(ListArray1) = False Then
QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray) = True Then GoTo ende_function
ListArray1 = ListArray_werk() 'Function aufrufen um aus Gesamtem array gewähltes Werk zu finden
If IsEmptyArray(ListArray1) = False Then
QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray) = True Then GoTo ende_function
ListArray1 = ListArray_Sap_aendertext() 'Function aufrufen um aus Gesamtem array nur Änderungen mit eingegebenem Stammtext zu finden
If IsEmptyArray(ListArray1) = False Then
QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray) = True Then GoTo ende_function
ListArray1 = ListArray_erstell_Datum() 'Function aufrufen um aus Gesamtem array nur benötigte daten zu finden
If IsEmptyArray(ListArray1) = False Then
QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray1) = True Then GoTo ende_function
ListArray1 = ListArray_Beauftragter_Name() 'Function aufrufen um aus Gesamtem array nur Daten mit gewünschtem Beauftragtem zu finden
If IsEmptyArray(ListArray1) = False Then
QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
x1 = 0
'Aus array einträge entfernen die leer sind
If IsEmptyArray(ListArray) = True Then GoTo ende_function
For X = 0 To UBound(ListArray1)
If ListArray1(X) "" Then
ReDim Preserve array_ohne_leerzellen(x1)
array_ohne_leerzellen(x1) = ListArray1(X)
x1 = x1 + 1
Else
End If
Next
If IsEmptyArray(array_ohne_leerzellen) = False Then
'Wenn Array nicht leer dan noch die restlichen Daten sortieren und an Listbox übergeben
QuickSort array_ohne_leerzellen
ListArray = array_ohne_leerzellen
Else
ListArray = Array("") 'Leeres Array an Listbox übergeben
End If
ende_function:
wait_form.Hide 'Userform ausblenden
Unload wait_form
End Function
'----------------------------------------------------------------------------------------------
'----------------------------------- UNTER FUNKTIONEN -----------------------------------------------------------
Function ListArray_bauteil()
'Kriterium Bauteil (Piezo oder MV)
n = -1
i = 0
For i = 1 To x1 - 2
If UCase(Left(arrTmp1(1, i), 1)) = UCase(strSuch) Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(arrTmp1(welche_suche, i))
End If
Next
If n > -1 Then
ReDim Preserve arrTmp2(n)
ListArray_bauteil = arrTmp2
Erase arrTmp2
Else
End If
End Function
Function ListArray_aenderstatus()
'Kriterium - genehmigte anzeigen oder nicht genehmigte Änderungen
n = -1
'prüfen ob kriterium gewünscht
If Me.genehmigte = False And Me.nicht_genehmigte = False Then
ListArray_aenderstatus = ListArray1
Exit Function
Else
End If
If Me.genehmigte = True Then
i = 0
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then 'Änderungsnummern sind gleich
If IsEmpty(arrTmp1(165, ii)) = False Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray1(i))
ii = 0
Exit For
End If
End If
Next
Next
Else
i = 0
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then 'Änderungsnummern sind gleich
If IsEmpty(arrTmp1(165, ii)) = True Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray1(i))
ii = 0
Exit For
End If
End If
Next
Next
End If
ListArray_aenderstatus = arrTmp2
Erase arrTmp2
End Function
Function ListArray_techn_or_proz()
'Kriterium Technische oder Prozess Änderungen
n = -1
If Not techn_btn = True And Not proz_btn = True Then
ListArray_techn_or_proz = ListArray1
Exit Function
Else
End If
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If techn_btn = True Then
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then
If InStr(UCase(arrTmp1(1, ii)), "P") = 0 Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray1(i))
Exit For
Else
ii = 0
Exit For
End If
End If
Else
If proz_btn = True Then
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then
If InStr(UCase(arrTmp1(1, ii)), "P") > 0 Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray1(i))
Exit For
End If
End If
End If
End If
Next ii
Next i
ListArray_techn_or_proz = arrTmp2
Erase arrTmp2
End Function
Function ListArray_werk()
n = -1
'Kriterium (Werke)
'Prüfen ob Werke gefüllt geändert wurde
If UCase(Me.werke.Value) "" Then
Else
ListArray_werk = ListArray1
Exit Function
End If
werkgenau = Split(obj_datenbank.Worksheets(2).Cells(Me.werke.ListIndex + 2, 6), ",")
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then 'Änderungsnummern sind gleich
For z = 0 To UBound(werkgenau) - 1
If InStr(1, UCase(arrTmp1(108, ii)), UCase(werkgenau(z))) Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray1(i))
'ii = 0 ' um immer wieder alle nummern in schleife durchzugehen
Exit For
Else
End If
Next
Else
End If
Next ii
Next i
ListArray_werk = arrTmp2
Erase arrTmp2
End Function
Function ListArray_Sap_aendertext()
'Kriterium SAP Änderungs-Stamm-text
n = -1
'prüfen ob in Textfeld Stammtext etwas eingegeben wurde.
If UCase(Me.stammtext.Value) "" Then
Else
ListArray_Sap_aendertext = ListArray1
Exit Function
End If
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then 'Änderungsnummern sind gleich
If InStr(1, UCase(arrTmp1(107, ii)), UCase(Me.stammtext.Value)) Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray1(i))
ii = 0
Exit For
End If
End If
Next
Next
ListArray_Sap_aendertext = arrTmp2
Erase arrTmp2
End Function
Function ListArray_erstell_Datum()
'Kriterium Erstellungsdatum der Änderung
n = -1
'prüfen ob textfelder gefüllt.(mindestens 1 datum muss vorhanden sein)
If ae_erstellt_von_dat.Value = "" And ae_erstellt_bis_dat.Value = "" Then
ListArray_erstell_Datum = ListArray1
Exit Function
Else
End If
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then 'Änderungsnummern sind gleich
'Prüfen ob Datums eingetragen in Comboboxen und in zelle in Datenbank
If IsDate(arrTmp1(103, ii)) = False Then
Exit For
Else
datum_akt = arrTmp1(103, ii)
End If
If IsDate(ae_erstellt_von_dat.Value) = False Then
datum_start = datum_akt - 1
Else
datum_start = ae_erstellt_von_dat.Value
End If
If IsDate(ae_erstellt_bis_dat.Value) = False Then
datum_ende = datum_akt + 1
Else
datum_ende = ae_erstellt_bis_dat.Value
End If
If datum_akt > datum_start And datum_akt
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = ListArray1(i)
ii = 0
Exit For
End If
End If
Next
Next
ListArray_erstell_Datum = arrTmp2
Erase arrTmp2
End Function
Function ListArray_Beauftragter_Name()
n = -1
'Kriterium Beauftragter name
'prüfen ob in Textfeld etwas eingegeben wurde.
If UCase(Me.beauftragter_name.Value) "" Then
Else
ListArray_Beauftragter_Name = ListArray1
Exit Function
End If
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then 'Änderungsnummern sind gleich
If InStr(1, UCase(arrTmp1(104, ii)) & " " & UCase(arrTmp1(105, ii)), UCase(Me.beauftragter_name.Value)) Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray1(i))
ii = 0
Exit For
End If
End If
Next
Next
ListArray_Beauftragter_Name = arrTmp2
Erase arrTmp2
End Function
'Prüfen ob Array gefüllt
Function IsEmptyArray(ByRef a As Variant) As Boolean
Dim Dummy As Long
If IsArray(a) Then
'Ggf. Fehler provozieren:
On Error Resume Next
Dummy = LBound(a)
'Ergebnis bestimmen:
IsEmptyArray = (Err.Number 0)
On Error GoTo 0
Else
On Error Resume Next
Err.Raise 13 'Type mismatch'
On Error GoTo 0
End If
End Function