VBA-Code Matrix erstellen mit / ohne Array

Hallo zusammen,

ich bin VBA-Neuling und benötige euer Wissen.
Ich habe eine "Qualifikationsmatrix" erstellt, jedoch ist der Code sehr langsam und das Tabellenblatt lädt oft 3-5 Sekunden lang. Ich habe mich dann belesen, dass Arrays die Verarbeitung beschleunigen und habe mich daran versucht. Das Ergebnis ist im Tabellenblatt "Matrix". Jedoch stelle ich nun fest, dass diese Matrix ebenfalls 3-5 Sekunden benötigt um erstellt zu werden.

https://www.herber.de/bbs/user/163112.xlsm

Habe ich etwas falsch gemacht? Ich habe ein Youtube-Tutorial gesehen, bei dem mehrere 100.000 Daten unter einer Sekunde in einer Matrix verarbeitet werden....
Habt ihr Tipps wie ich die Datei, Tabellen oder den Code ggf. anders aufbauen kann das ganze zu beschleunigen?

Kurze Infos zum Aufbau:
- Mitarbeitermanagement: hier werden die Mitarbeiterdaten gespeichert
- Schulungsmanagement: hier werden die Schulungsdaten definiert und für welche Abteilung und Funktion sie relevant sind
- Qualifikationszuordnung: hier werden den Mitarbeitern die Schulungen zugeordnet

Die Matrix soll wie im Tabellenblatt "Qualifikationsmatrix" aufgebaut sein. Sprich die Mitarbeiterdaten sollen als y-Koordinate aus dem Tabellenblatt "Mitarbeitermanagement" übernommen werden und die Schulungen aus dem Tabellenblatt "Schulungsmanagement" als x-Koordinate.
Die Gültigkeitswerte aus dem Tabellenblatt "Qualifikationszuordnung" beschreiben, ob die Schulung noch gültig ist oder nicht und sollen in den Wertebereich übernommen werden.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

hier versuch mal damit was anzufangen. läuft unter 1 Sekunde durch.

Option Explicit



Sub MatrixErstellen()

    Dim wsSchulungen As Worksheet, wsMitarbeiter As Worksheet, wsMatrix As Worksheet, wsZuordnung As Worksheet

    Dim LastSchulungRow&, LastMitarbeiterRow&, LastZuordnungRow&

    Dim i As Long, j As Long, k As Long

    Dim arr, arrZuord, arrErg

    

    Dim start As Double

    start = Timer

    

    ' Deaktivieren der Bildschirmaktualisierung

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

  



    Set wsSchulungen = ThisWorkbook.Sheets("Schulungsmanagement")

    Set wsMitarbeiter = ThisWorkbook.Sheets("Mitarbeitermanagement")

    Set wsZuordnung = ThisWorkbook.Sheets("Qualifikationszuordnung")

    

        

    LastSchulungRow = wsSchulungen.Cells(wsSchulungen.Rows.Count, "B").End(xlUp).Row

    LastMitarbeiterRow = wsMitarbeiter.Cells(wsMitarbeiter.Rows.Count, "B").End(xlUp).Row

    LastZuordnungRow = wsZuordnung.Cells(wsZuordnung.Rows.Count, "C").End(xlUp).Row

    

    

    

    ' Zugreifen auf das vorhandene Arbeitsblatt "Matrix"

    On Local Error Resume Next

    Set wsMatrix = ThisWorkbook.Sheets("Matrix")

    If Err > 0 Then

       ' Wenn das Arbeitsblatt "Matrix" nicht existiert, erstellen

        Set wsMatrix = ThisWorkbook.Worksheets.Add

        wsMatrix.name = "Matrix"

        Err.Clear

    Else

     wsMatrix.UsedRange.Clear

    End If

    On Error GoTo 0

    

    'Überschriften in das Blatt

    wsMatrix.Cells(3, 2).Resize(1, 4) = Array("Personalnr.", "Name", "Abteilung", "Funktion")

    

   ' Kopieren der Schulungen in das Blatt

    arr = wsSchulungen.Cells(3, 2).Resize(LastSchulungRow - 2).Value

     wsMatrix.Cells(3, 6).Resize(1, UBound(arr)) = Application.Transpose(arr)

    

    ' Kopieren der Mitarbeiterdaten Bereich 1 in das Blatt

    arr = wsMitarbeiter.Cells(3, 2).Resize(LastMitarbeiterRow - 2, 2).Value

    wsMatrix.Cells(4, 2).Resize(UBound(arr, 2)) = arr

    

    ' Kopieren der Mitarbeiterdaten Bereich 2 in das Blatt

    arr = wsMitarbeiter.Cells(4, 6).Resize(LastMitarbeiterRow - 3, 2).Value

    wsMatrix.Cells(4, 4).Resize(UBound(arr), 2) = arr

    

   

    'vergleichstabelle Zuordnungenin Array

    arrZuord = wsZuordnung.Cells(3, 2).Resize(LastZuordnungRow - 3 + 1, 12)

    

    'Daten aus Matrix in Array

    arrErg = wsMatrix.UsedRange.Value



    For i = LBound(arrErg) + 1 To UBound(arrErg)

    

          For j = LBound(arrZuord) To UBound(arrZuord)

            

            If arrErg(i, 2) = arrZuord(j, 2) Then                    ' Mitarbeitername passt

            'Debug.Print arrErg(i, 2) & " = " & arrZuord(j, 2)

               For k = 5 To UBound(arrErg, 2)                       'schleife über schulungen

                 

                   If arrErg(1, k) = arrZuord(j, 5) Then             'schulung passt

                   'Debug.Print arrErg(1, k) & " = " & arrZuord(j, 5)

                   arrErg(i, k) = arrZuord(j, 8)

                   Exit For

                   End If

               Next k

           End If

         Next j

     

    Next i

    

    ' Das Array in das Arbeitsblatt "Matrix" schreiben

    wsMatrix.UsedRange = arrErg

   

    ' Aktivieren der Bildschirmaktualisierung

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

    Dim dblend As Double

    dblend = Timer

    Debug.Print "Ende Modul 1: " & Format((dblend - start), "0.000") & " Sekunden"

   

End Sub

Beliebteste Forumthreads (12 Monate)

VBA-Code Matrix erstellen mit / ohne Array

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

49 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA-Code Matrix erstellen mit / ohne Array

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

49 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread