Optimierung möglich?

Sub test(M1 As Long, M2 As Long, M3 As Long, M4 As Long, M5 As Long, M6 As Long, M7 As Long, M8 As Long, M9 As Long, M10 As Long, AkS1 As Boolean, AkS2 As Boolean, AkS3 As Boolean, AkS4 As Boolean, AkS5 As Boolean, AkS6 As Boolean, AkS7 As Boolean, AkS8 As Boolean, AkS9 As Boolean, AkS10 As Boolean)
Dim Merkmalnummer(1 To 10) As Long
Dim Merkmal(0 To 10) As String
Dim Zeile(500, 10) As Integer
Dim i As Integer, j As Byte
Dim aa As Byte, bb As Long
Dim Hilfszähler As Byte
Dim c As Range
Dim b(100) As Integer
Dim Zeitpunkt(5000) As Date
Dim Werte(5000, 10) As Single
Dim Spannweiten(1 To 5000, 0 To 2) As Single
Dim firstaddress As String
Dim Start As Double
Dim k As Date
Start = Timer
Debug.Print " gestartet um: " & Format(Now - k, "hh:mm:ss")
Application.ScreenUpdating = False
'ausgewählte Elemente übernehmen
'hier werden die Merkmalnummern in ein Datenfeld übertragen
j = 0
If M1 <> 0 Then j = j + 1: Merkmalnummer(j) = M1
If M2 <> 0 Then j = j + 1: Merkmalnummer(j) = M2
If M3 <> 0 Then j = j + 1: Merkmalnummer(j) = M3
If M4 <> 0 Then j = j + 1: Merkmalnummer(j) = M4
If M5 <> 0 Then j = j + 1: Merkmalnummer(j) = M5
If M6 <> 0 Then j = j + 1: Merkmalnummer(j) = M6
If M7 <> 0 Then j = j + 1: Merkmalnummer(j) = M7
If M8 <> 0 Then j = j + 1: Merkmalnummer(j) = M8
If M9 <> 0 Then j = j + 1: Merkmalnummer(j) = M9
If M10 <> 0 Then j = j + 1: Merkmalnummer(j) = M10
Sheets("Tabelle1").Activate
bb = 0
For i = 1 To j 'j=Anzahl der ausgewählten Merkmale bzw. Untermerkmale
aa = 0
'Zeilennummmern der ausgewählten Merkmale auslesen
'bei Tabelle 1 können locker 10000 Zeilen belegt sein, die zu suchenden Merkmal(Blocknummern) sind dann weit verstreut
With ActiveSheet.Range("A:A")
Set c = .Find(Merkmalnummer(i), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
aa = aa + 1
'Datenfeld Zeile(aa,1) ist Hauptmerkmal, Zeile(aa,i) Unterkriterien insgesamt bis zu 10
Zeile(aa, i) = c.Row
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
Next i
'Merkmal mit Unterkriterien erfassen
'Hauptmerkmal
Merkmal(0) = Cells(Zeile(1, 1), 4)
'Abfrage, bei nur einem vorhandenen Kriterium (ohne Unterkriterien) würde sonst eine 0 eingetragen werden
If Cells(Zeile(1, 1), 6) = 0 Then
If M1 <> 0 Then Merkmal(1) = ""
Else
If M1 <> 0 Then Merkmal(1) = Cells(Zeile(1, 1), 6)
End If
If M2 <> 0 Then Merkmal(2) = Cells(Zeile(1, 2), 6)
If M3 <> 0 Then Merkmal(3) = Cells(Zeile(1, 3), 6)
If M4 <> 0 Then Merkmal(4) = Cells(Zeile(1, 4), 6)
If M5 <> 0 Then Merkmal(5) = Cells(Zeile(1, 5), 6)
If M6 <> 0 Then Merkmal(6) = Cells(Zeile(1, 6), 6)
If M7 <> 0 Then Merkmal(7) = Cells(Zeile(1, 7), 6)
If M8 <> 0 Then Merkmal(8) = Cells(Zeile(1, 8), 6)
If M9 <> 0 Then Merkmal(9) = Cells(Zeile(1, 9), 6)
If M10 <> 0 Then Merkmal(10) = Cells(Zeile(1, 10), 6)
'Restliche Daten erfassen Datum, Istmaß...
For i = 1 To aa
'mit First wurde immer der Anfang von einer Übertragung gekennzeichnet (die Übertragungen sind Tabellenblätter die immer einen Monatsblock beinhalten
b(i) = ActiveSheet.Range("A1:A" & Zeile(i, 1)).Find(what:="First", SearchDirection:=xlPrevious).Row
For Hilfszähler = 10 To 253 Step 3 'erste mögliche Eintragung in Spalte 10, nächste mögliche Eintragung in Spalte 13 usw.
'wenn Spalte kein Datum mehr vorhanden dann Schleife verlassen
If Cells(b(i), Hilfszähler) = 0 Then Exit For
'gefundene Eintragungen hochzählen
bb = bb + 1
'Datum immer auslesen
Zeitpunkt(bb) = Cells(b(i), Hilfszähler) 'Datum auslesen
'Aks... sind Checkboxen die auf einem Hauptplaton angewählt werden können
'wenn 1. Merkmal aktiviert wurde auslesen
If AkS1 = True Then Werte(bb, 1) = Cells(Zeile(i, 1), Hilfszähler - 1)   'Istmaß auslesen
'wenn 2. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS2 = True And M2 <> 0 Then Werte(bb, 2) = Cells(Zeile(i, 2), Hilfszähler - 1) 'Istmaß auslesen
'wenn 3. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS3 = True And M3 <> 0 Then Werte(bb, 3) = Cells(Zeile(i, 3), Hilfszähler - 1) 'Istmaß auslesen
'wenn 4. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS4 = True And M4 <> 0 Then Werte(bb, 4) = Cells(Zeile(i, 4), Hilfszähler - 1) 'Istmaß auslesen
'wenn 5. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS5 = True And M5 <> 0 Then Werte(bb, 5) = Cells(Zeile(i, 5), Hilfszähler - 1) 'Istmaß auslesen
'wenn 6. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS6 = True And M6 <> 0 Then Werte(bb, 6) = Cells(Zeile(i, 6), Hilfszähler - 1) 'Istmaß auslesen
'wenn 7. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS7 = True And M7 <> 0 Then Werte(bb, 7) = Cells(Zeile(i, 7), Hilfszähler - 1) 'Istmaß auslesen
'wenn 8. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS8 = True And M8 <> 0 Then Werte(bb, 8) = Cells(Zeile(i, 8), Hilfszähler - 1) 'Istmaß auslesen
'wenn 9. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS9 = True And M9 <> 0 Then Werte(bb, 9) = Cells(Zeile(i, 9), Hilfszähler - 1) 'Istmaß auslesen
'wenn 10. Merkmal aktiviert wurde und Merkmal vorhanden ist auslesen
If AkS10 = True And M10 <> 0 Then Werte(bb, 10) = Cells(Zeile(i, 10), Hilfszähler - 1) 'Istmaß auslesen
'Diese Daten immer auslesen
Spannweiten(bb, 0) = Cells(Zeile(i, 1), 7) 'Hauptwert auslesen
Spannweiten(bb, 1) = Cells(Zeile(i, 1), 7) + Cells(Zeile(i, 1), 7 + 1) 'Nebenwert1 auslesen
Spannweiten(bb, 2) = Cells(Zeile(i, 1), 7) + Cells(Zeile(i, 1) + 1, 7 + 1) 'Nebenwert2 auslesen
Next Hilfszähler
Next i
'_________________________________________________________________________________________________________________________
'Daten übertragen
Sheets("Tabelle3").Activate
Columns("A:O").ClearContents
'Hauptmerkmal
Cells(1, 1) = Merkmal(0)
'Unterkriterien
Cells(1, 3) = "Hauptwert"
Cells(1, 4) = "Nebenwert1"
Cells(1, 5) = "Nebenwert2"
If Merkmal(1) <> "0" Then Cells(1, 6) = Merkmal(1)
Cells(1, 7) = Merkmal(2)
Cells(1, 8) = Merkmal(3)
Cells(1, 9) = Merkmal(4)
Cells(1, 10) = Merkmal(5)
Cells(1, 11) = Merkmal(6)
Cells(1, 12) = Merkmal(7)
Cells(1, 13) = Merkmal(8)
Cells(1, 14) = Merkmal(9)
Cells(1, 15) = Merkmal(10)
'Datum
For i = 1 To bb
Cells(i + 1, 1) = i & "M- " & Zeitpunkt(i)
'Hauptwert
Cells(i + 1, 3) = Spannweiten(i, 0)
'Nebenwert1
Cells(i + 1, 4) = Spannweiten(i, 1)
'Nebenwert2
Cells(i + 1, 5) = Spannweiten(i, 2)
Next i
'hier werden nur die Daten übertragen die ausgewählt wurden
For aa = 1 To j
Select Case aa
Case 1
For i = 1 To bb
Cells(i + 1, 6) = Werte(i, 1)
Next i
Case 2
For i = 1 To bb
Cells(i + 1, 7) = Werte(i, 2)
Next i
Case 3
For i = 1 To bb
Cells(i + 1, 8) = Werte(i, 3)
Next i
Case 4
For i = 1 To bb
Cells(i + 1, 9) = Werte(i, 4)
Next i
Case 5
For i = 1 To bb
Cells(i + 1, 10) = Werte(i, 5)
Next i
Case 6
For i = 1 To bb
Cells(i + 1, 11) = Werte(i, 6)
Next i
Case 7
For i = 1 To bb
Cells(i + 1, 12) = Werte(i, 7)
Next i
Case 8
For i = 1 To bb
Cells(i + 1, 13) = Werte(i, 8)
Next i
Case 9
For i = 1 To bb
Cells(i + 1, 14) = Werte(i, 9)
Next i
Case 10
For i = 1 To bb
Cells(i + 1, 15) = Werte(i, 10)
Next i
End Select
Next aa
Application.ScreenUpdating = True
Debug.Print " beendet um: " & Format(Now - k, "hh:mm:ss")
Debug.Print Format(Timer - Start, "#0.00") & " Sekunden gerödelt!"
UserForm3.Caption = Format(Timer - Start, "#0.00") & " Sekunden gerödelt!"
End Sub