habe wieder einmal ein anliegen wo es um codeoptrimierung geht:(
Mein Code braucht ca: 5-10 sekunden für die ausführung.
Würde mich sehr freuen wenn mir jemand helfen könnte meinen code etwas zu optimieren.
Ich weiß mein code ist ziemlich lange Aber auch über tipps bin ich sehr dankbar.
Leider musste ich die Variablen und functionen umbenennen weil ich den code auf meiner Arbeit versuche zu erstellen.
Bin wirklich sehr dankebar für Tipps.
Danke und schönen Tag an alle.
Option Explicit
Dim arrTmp1, arrTmp2(), arrtmp11, i As Long, 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 ListArray2
Dim ListArray3
Dim ListArray4
Dim ListArray5
Dim ListArray6
Dim ii As Integer
Dim werkgenau
Dim z
Dim x
Dim x2
Dim welche_suche As Integer
Dim array_ohne_leerzellen()
Private Sub UserForm_Initialize()
If main_project_form.btn_find_cnumber.Tag = "ok" Then
Me.sel_nummer.Caption = "selektierte ÄNummer"
welche_suche = 1
End If
If main_project_form.btn_find_onumber.Tag = "ok" Then
Me.sel_nummer.Caption = "selektierte ONummer"
welche_suche = 2
End If
werke.List = obj_datenbank.Worksheets(2).Range("w").Value
End Sub
Private Sub stxt_ok_Click()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub name_ok_btn_Click()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub stxt_ok_btn_Click()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub ae_erstellt_bis_dat_Change()
Me.bea_name.SetFocus
'Daten aus Spalte
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub ae_erstellt_von_dat_Change()
'Daten aus Spalte
Me.bea_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.bea_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.bea_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 m_btn_Click()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub pi_btn_Click()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub te_btn_Click()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub pr_btn_Click()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub we_Change()
Me.selectet_numbers_lb.Clear
Me.selectet_numbers_lb.List = ListArray()
End Sub
Private Sub stxt_Change()
'Aktion erst bei klicken des Buttons "Text_ok"
End Sub
Private Sub bea_name_Change()
'Aktion erst bei klicken des Buttons "Name_ok"
End Sub
Private Sub abbruch_Click()
Me.Hide
Unload Me
End Sub
Private Sub Zeige_a_nummer_Click()
Dim aenumbers
Dim s As Integer
s = 0
For Each aenumbers In main_project_form.cbo_cnumber.List
If UCase(selectet_numbers_lb.Value) = UCase(anumbers) Then
Me.Hide
main_project_form.cbo_cnumber.ListIndex = s
Unload Me
Exit For
Else
s = s + 1
End If
Next
End Sub
'-----------------------------------------------------------------
'----------------------------------------------------------------------------------------------
'----------------------------------- Haupt - FUNKTION -----------------------------------------------------------
'ruft die einzelnen Unterfunktionen(Kriterien) auf
Function ListArray()
If Not (m_btn Or pi_btn) Then
MsgBox ("Bitte zuerst b
wählen "), vbCritical, "abbruch"
Unload Me
find_cnumber_form.Show
ListArray = Array("")
Exit Function
End If
wait_form.Caption = "bitte warten ..."
wait_form.Label1.Caption = "bitte warten ... please wait"
wait_form.Show
wait_form.Repaint
With obj_datenbank.Worksheets(1)
x1 = .Cells(.Rows.Count, 1).End(xlUp).Row
'Array füllen über alle Spalten in Datenbank 256 Spalten
arrTmp1 = .Range(.Cells(3, 1), .Cells(x1, 256))
arrTmp1 = WorksheetFunction.Transpose(arrTmp1)
End With
n = -1
If piezo_btn = True Then
strSuch = "F"
ElseIf mv_btn = True Then
strSuch = "4"
Else
strSuch = ""
End If
ListArray1 = ListArray_bt()
If IsEmptyArray(ListArray1) = False Then
' QuickSort ListArray1
ListArray = ListArray1
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray1) = True Then GoTo ende_function
ListArray2 = ListArray_techn_or_proz()
If IsEmptyArray(ListArray2) = False Then
' QuickSort ListArray2
ListArray = ListArray2
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray2) = True Then GoTo ende_function
ListArray3 = ListArray_we()
If IsEmptyArray(ListArray3) = False Then
' QuickSort ListArray3
ListArray = ListArray3
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray3) = True Then GoTo ende_function
ListArray4 = ListArray_Stext()
If IsEmptyArray(ListArray4) = False Then
' QuickSort ListArray4
ListArray = ListArray4
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray4) = True Then GoTo ende_function
ListArray5 = ListArray_e_Datum()
If IsEmptyArray(ListArray5) = False Then
' QuickSort ListArray5
ListArray = ListArray5
Else
ListArray = Array("")
End If
If IsEmptyArray(ListArray5) = True Then GoTo ende_function
ListArray6 = ListArray_Bea_Name()
If IsEmptyArray(ListArray6) = False Then
' QuickSort ListArray6
ListArray = ListArray6
Else
ListArray = Array("")
End If
x1 = 0
For x = 0 To UBound(ListArray6)
If ListArray6(x) "" Then
ReDim Preserve array_ohne_leerzellen(x1)
array_ohne_leerzellen(x1) = ListArray6(x)
x1 = x1 + 1
Else
End If
Next
If IsEmptyArray(array_ohne_leerzellen) = False Then
QuickSort array_ohne_leerzellen
ListArray = array_ohne_leerzellen
Else
ListArray = Array("")
End If
ende_function:
wait_form.Hide
Unload wait_form
End Function
'----------------------------------------------------------------------------------------------
'----------------------------------- UNTER FUNKTIONEN -----------------------------------------------------------
Function ListArray_bt()
'Kriterium
n = -1
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_bt = arrTmp2
Erase arrTmp2
Else
End If
End Function
Function ListArray_top()
n = -1
If Not techn_btn = True And Not proz_btn = True Then
ListArray_top = ListArray1
Exit Function
Else
End If
For i = 0 To UBound(ListArray1)
For ii = 1 To x1 - 2
If te_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 pr_btn = True Then
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray1(i)) Then
'If InStr(UCase(ListArray1(i)), "P") 0 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_top = arrTmp2
Erase arrTmp2
End Function
Function ListArray_we()
n = -1
If UCase(Me.we.Value) "" Then
Else
ListArray_we = ListArray2
Exit Function
End If
werkgenau = Split(obj_datenbank.Worksheets(2).Cells(Me.werke.ListIndex + 2, 6), ",")
For i = 0 To UBound(ListArray2)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray2(i)) Then
For z = 0 To UBound(wegenau) - 1
If InStr(1, UCase(arrTmp1(108, ii)), UCase(wegenau(z))) Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray2(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_we = arrTmp2
Erase arrTmp2
End Function
Function ListArray_Stext()
n = -1
If UCase(Me.stxt.Value) "" Then
Else
ListArray_Sap_artext = ListArray3
Exit Function
End If
For i = 0 To UBound(ListArray3)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray3(i)) Then
If InStr(1, UCase(arrTmp1(107, ii)), UCase(Me.stxt.Value)) Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray3(i))
ii = 0
Exit For
End If
End If
Next
Next
ListArray_Sap_aext = arrTmp2
Erase arrTmp2
End Function
Function ListArray_erstell_Datum()
n = -1
If ae_erstellt_von_dat.Value = "" And ae_erstellt_bis_dat.Value = "" Then
ListArray_erstell_Datum = ListArray4
Exit Function
Else
End If
For i = 0 To UBound(ListArray4)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray4(i)) Then
'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) = ListArray4(i)
ii = 0
Exit For
End If
End If
Next
Next
ListArray_erstell_Datum = arrTmp2
Erase arrTmp2
End Function
Function ListArray_Bea_Name()
n = -1
n = -1
'prüfen ob in Textfeld Stxt etwas eingegeben wurde.
If UCase(Me.bea_name.Value) "" Then
Else
ListArray_Bea_Name = ListArray5
Exit Function
End If
For i = 0 To UBound(ListArray5)
For ii = 1 To x1 - 2
If UCase(arrTmp1(welche_suche, ii)) = UCase(ListArray5(i)) Then
nummern sind gleich
If InStr(1, UCase(arrTmp1(104, ii)) & " " & UCase(arrTmp1(105, ii)), UCase(Me.bea_name.Value)) Then
n = n + 1
ReDim Preserve arrTmp2(n)
arrTmp2(n) = UCase(ListArray3(i))
ii = 0
Exit For
End If
End If
Next
Next
ListArray_Bea_Name = arrTmp2
Erase arrTmp2
End Function
'Prüfen ob Array gefüllt um Listbox zu füllen
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