Hallo,

ich habe ein kleines performanceproblem.

Ich  möchte Datensätze zweier Tabellen miteinander vergleichen und die Abweichungen aus beiden Tabellen in eine neue Tabelle schreiben.

Die Datensätze beinhalten lediglich Personendaten.

Drei Unterscheidungsmerkmale habe ich in die Auswahl genommen

a) Arbeitsplatz

b) Personalnummer

c) Steuernummer

Da die Tabellen jeweils bis zu 20000 Datensätze beinhalten dauert meine Programmierung sehr lange!

Ich muss dazu sagen, dass ich blutiger Anfänger in Sachen VBA bin und ich bei Fragen auf das Forum angewiesen bin.

Vielleicht hat jemand von den Spezialisten eine Idee, wie ich den Quellcode besser schreiben kann, um die Laufzeit zu verkürzen.

Ich hatte auch wegen der großen Datenmenge überlegt, die Tabellen mit Hilfe von Access abzufragen, indem ich via vba beide Tabellen zunächst als Datei abspeichere anschließend eine Access-DB öffne, die beide Excel-Dateien bereits verknüpft hat. Danach würde ich ein SQL-Statement ausführen lassen und mir die Ergebnisse wieder ins Workbook hole und in eine neue Tabelle schreibe.

Was meint ihr?

Hier meine Quellcode zur Ansicht. Vielen Dank schon mal für die Hilfe!!

Option Explicit

Sub Personen_Abgleich()

Dim izeile, ispalte, izeileEnde, izeilews As Integer
Dim ws As Worksheet
Dim ws_abg As Worksheet
Dim ws_ges As Worksheet
Dim Bereich As Range
Dim sarbeitsplatz As String
Dim spersonennr As String
Dim ssteuernr As String

Dim bpersneu As Boolean

Set ws_ges = Application.ActiveWorkbook.Worksheets("Personen1")
Set ws = Application.ActiveWorkbook.Worksheets("Personen2")
Set ws_abg = Application.ActiveWorkbook.Worksheets("Personen_Abgleich")

'Abgleich starten

ws_abg.Activate
ws_abg.Cells(1, 1).Select

ws_abg.Rows("3:20000").Select
Selection.Delete

izeile = 3
izeilews = 3

ws_ges.Activate

    Do Until ws_ges.Cells(izeile, 1) = ""
   
        If ws_ges.Cells(izeile, 17) = "" Then     'hier wird gefiltert, ob die Person noch aktuell im Unternehmen ist (EndeDatum offen)
       
       sarbeitsplatz = ws_ges.Cells(izeile, 1)
       spersonennr = ws_ges.Cells(izeile, 2)
       ssteuernr = ws_ges.Cells(izeile, 6)
       
        abgleich sarbeitsplatz, spersonennr, ssteuernr  

       'hier werden jetzt die fehlenden Personen aus Tabelle 2 in die neue Tabelle geschrieben

            If bpersneu = True Then
           
            ws_abg.Cells(izeilews, 1) = ws_ges.Cells(izeile, 1)
            ws_abg.Cells(izeilews, 2) = ws_ges.Cells(izeile, 2)
            ws_abg.Cells(izeilews, 3) = ws_ges.Cells(izeile, 3)
            ws_abg.Cells(izeilews, 4) = ws_ges.Cells(izeile, 4)
            ws_abg.Cells(izeilews, 5) = ws_ges.Cells(izeile, 5)
            ws_abg.Cells(izeilews, 6) = ws_ges.Cells(izeile, 6)
            ws_abg.Cells(izeilews, 7) = ws_ges.Cells(izeile, 7)
            ws_abg.Cells(izeilews, 8) = ws_ges.Cells(izeile, 8)
            ws_abg.Cells(izeilews, 9) = ws_ges.Cells(izeile, 9)
            ws_abg.Cells(izeilews, 10) = ws_ges.Cells(izeile, 10)
            ws_abg.Cells(izeilews, 11) = ws_ges.Cells(izeile, 11)
            ws_abg.Cells(izeilews, 12) = ws_ges.Cells(izeile, 12)
            ws_abg.Cells(izeilews, 13) = ws_ges.Cells(izeile, 13)
            ws_abg.Cells(izeilews, 14) = ws_ges.Cells(izeile, 14)
            ws_abg.Cells(izeilews, 15) = ws_ges.Cells(izeile, 15)
            ws_abg.Cells(izeilews, 16) = ws_ges.Cells(izeile, 16)
            ws_abg.Cells(izeilews, 17) = ws_ges.Cells(izeile, 17)
            ws_abg.Cells(izeilews, 18) = "Neu"
           
            izeilews = izeilews + 1
            End If
        End If
    izeile = izeile + 1
   
    Loop

End Sub

'mit der Funktion vergleiche ich die 3 Kriterien aus Tab 1 mit Tab2 und merke mir die Abweichung

Function abgleich(ByVal sarbeitsplatz As String, ByVal spersonennr As String, ByVal ssteuernr As String)

Dim ws As Worksheet
Dim izeile As Integer
Dim izeile1 As Integer

Set ws = Application.ActiveWorkbook.Worksheets("Personen2")

ws.Activate

izeile = 3

    If ws.Cells(izeile, 17) = "" Then  'auch hier vergleich ich nur Personen, die aktuell im Untenehmen beschäftigt sind
   
   
        Do Until ws.Cells(izeile, 2) = ""
       
            If ws.Cells(izeile, 1) = sarbeitsplatz And ws.Cells(izeile, 2) = spersonennr And ws.Cells(izeile, 6) = ssteuernr Then
           
            bpersneu = False
           
            Exit Function
           
            Else
           
            bpersneu = True
           
            End If
       
        izeile = izeile + 1
       
        Loop
     Else
    
     izeile = izeile + 1
     End If
   

End Function