Zwei Sheets vergleichen und umkopieren

Hallo zusammen,

ich benötige dringend Unterstützung.
Leider finde ich keine bessere Lösung.
Folgendes:
Es sollen 2 Sheets miteinander abgeglichen und kopiert werden.
Also Sheet 2 (Mit den Änderungen) soll mit Sheet1 (MASTER) Zeile für Zeile verglichen werden. Also nur die in "A1" mit einer eindeutigen Nummer.
Ist die Zeile in er MASTER gefunden soll die Zeile von Sheet2 in Sheet1 kopiert werden.
Das klappt auch soweit. ABER die Sheet1 (MASTER) hat über 15.000 Zeilen.
Der durchlauf dauert über 30min.....
Hatte es auch mal das es 2min gedauert hat aber das hat sich warum auch immer geändert.


HILFE :D

Anbei mein Versuch...

DATEI:
https://www.herber.de/bbs/user/159665.xlsm

Sub AusBereinigung()
    
Dim wkb As Workbook
Dim wkb1 As Workbook
Dim wks As Worksheet
Dim wks1 As Worksheet
Dim rng As Range
Dim iRow As Integer
Dim i
Dim Anz As Integer
Dim anz1 As Integer
Dim Z
Dim SuchWert As String
Dim c
Dim s


MsgBox "Vorgang kann bis zu 30min dauern !"


Sheets("Sheet2").Select
If ActiveSheet.FilterMode = True Then
      ActiveSheet.ShowAllData
   End If

 Range("A1").Select
    ActiveWorkbook.Worksheets("Sheet2").ListObjects("TabelleSheet2").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").ListObjects("TabelleSheet2").Sort. _
        SortFields.Add Key:=Range("A1:A7361"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").ListObjects("TabelleSheet2"). _
        Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Application.ScreenUpdating = False
On Error Resume Next
On Error GoTo 0
Set wkb = Workbooks("Umkopieren - TEST.xlsm")
Set wkb1 = Workbooks("Umkopieren - TEST.xlsm")
wkb1.Activate
Set wks = Worksheets("Sheet1") 'wkb.Worksheets("Sheet2")
Set wks1 = Worksheets("Sheet2") 'wkb1.Worksheets("Finale Umlagerungstabelle")
Anz = wks.Cells(65536, 1).End(xlUp).Row
anz1 = wks1.Cells(65536, 1).End(xlUp).Row
For Z = 2 To anz1
SuchWert = wks1.Cells(Z, 1)
With wks.Range("a3:a" & Anz)
Set c = .Find(SuchWert, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
For s = 2 To 25

'Werte einzeln kopieren
wks.Cells(c.Row, s) = wks1.Cells(Z, s)



Next
Else
For s = 1 To 25
wks.Cells(Anz + 1, s) = wks1.Cells(Z, s)
Next
Anz = wks.Cells(65536, 1).End(xlUp).Row
End If
End With
Next
Application.ScreenUpdating = True

End Sub